It would help to know what error message you get when it breaks there.
Here's what is going on in that section - it is dependent on the For - Next
loop just above it. Just ahead of the For - Next loop it has taken a code
(SGC, TAV, ABC, etc) that it found on the row with the new information and
made sure it is in all CAPS and has no leading/trailing spaces. The For -
Next loop then compares that foundCode to all of the codes currently in row 1
of the new sheet until it finds a match. When it finds a match, it remembers
the column number in foundColumn.
But if it doesn't find a match, then at the end of the For - Next loop,
foundColumn is zero (there is no such column number). So inside of the If
foundColumn = 0 Then section, it first finds the next empty column in row 1
(codeList.Columns.Count + 1)
Then it simply puts the new code into that column. Right after that it
'rebuilds' the reference to where the labels are on row 1 on the second sheet.
I suspect that the value of foundColumn is greater than the number of
columns available in your version of Excel (256 for Excel 2003). The big
question (if I'm right) is how did it get that big? Your second sheet should
have labels in row 1, with at least 2 lables to begin with in A1 and B1, as
(I'll show 3)
A B C
1 ID 1st Name Surname
It would be even better if you placed a couple more in D1, E1, etc. But I
thought you might have a lot of them, so I wrote the code to add new ones to
the end of that list when they were found.
foundColumn could get too large, if:
#1 your first row on the new sheet starts out empty (foundColumn immediately
becomes Columns.Count + 1 which is 1 past the last available column, and is a
no-no).
#2 you have over 253 distinct codes to deal with (assuming you have 1st 3
columns with labels representing other things like I showed above). When it
tries to find a place for the 254th code, it chokes because again it is
trying to put something into a column that cannot exist.
I do presume that you changed the values for constants SourceSheetName and
DestSheetName to the appropriate worksheet names in your workbook. Otherwise
it wouldn't have made it as far as it did. Or at least your source list
already is on 'Sheet1' and 'Sheet2' is all set up to receive the results of
the processing.
I've modified the code somewhat to test for trying to put something into a
column that doesn't exist (foundColumn > Columns.Count) and announce it and
"gracefully" abort the operation if that happens. It may help us in our
search for a cure. Copy and paste (and edit sheet names if needed) the code
below over what you have now - throw away the old code, replace it with this
and give it another try.
If the information in the workbook isn't too sensitive (I always treat any
workbook I receive as VERY sensitive and confidential when actual data is
contained in it) you could send me a copy attached to an email and I can dig
into it further if the new code doesn't show us anything useful. My email
address (remove spaces) is
HelpFrom @ jlatham site.com
Remind me in the email what it's all about - I should recognize it, but
sometimes I get several workbooks and end up at a loss as to what the heck
I'm supposed to do with them. Even a link in the email to the original post
here is a big help.
Sub CombineData()
Dim sourceSheet As Worksheet
Const SourceSheetName = "Sheet1" ' change if required
Dim sourceRange As Range ' for list of IDs
Dim anySourceEntry As Range ' individual ID entry
Dim destSheet As Worksheet
Const DestSheetName = "Sheet2" ' change if required
Dim destRange As Range ' for list of IDs
Dim anyDestEntry As Range ' individual ID entry
Dim codeList As Range ' labels on row 1 on dest sheet
Dim anyCodeEntry ' individual labels
Dim foundRow As Long
Dim foundColumn As Integer
Dim foundCode As String
Dim baseCell As Range ' for entries on destSheet
Set sourceSheet = ThisWorkbook.Worksheets(SourceSheetName)
Set sourceRange = sourceSheet.Range("A2:" & _
sourceSheet.Range("A" & Rows.Count).End(xlUp).Address)
Set destSheet = ThisWorkbook.Worksheets(DestSheetName)
Set codeList = destSheet.Range("A1:" & _
destSheet.Range("A1").End(xlToRight).Address)
Set sourceRange = sourceSheet.Range("A2:" & _
sourceSheet.Range("A" & Rows.Count).End(xlUp).Address)
For Each anySourceEntry In sourceRange
'must determine destRange each time thru the loop
Set destRange = destSheet.Range("A1:" & _
destSheet.Range("A" & Rows.Count).End(xlUp).Address)
foundRow = 0
For Each anyDestEntry In destRange
If anyDestEntry = anySourceEntry Then
foundRow = anyDestEntry.Row
Exit For
End If
Next
If foundRow = 0 Then
'a new entry, set up to add to bottom
'of the destination sheet list
foundRow = destSheet.Range("A" & Rows.Count).End(xlUp). _
Offset(1, 0).Row
End If
Set baseCell = destSheet.Range("A" & foundRow)
'here we keep from overwriting previously found
'ID and name so 1st one found is always used
If IsEmpty(baseCell) Then
'new entry, put the info on the sheet
'the ID number
baseCell = anySourceEntry
'the first name
baseCell.Offset(0, 1) = anySourceEntry.Offset(0, 1)
'the last name
baseCell.Offset(0, 2) = anySourceEntry.Offset(0, 2)
End If
'get the Code for the found item
foundCode = UCase(Trim(anySourceEntry.Offset(0, 3)))
'look through the labels on dest sheet for the code
For Each anyCodeEntry In codeList
foundColumn = 0 ' in case we don't match one
If UCase(Trim(anyCodeEntry)) = foundCode Then
foundColumn = anyCodeEntry.Column
Exit For
End If
Next
If foundColumn = 0 Then
'was a no match, put out in empty column
foundColumn = codeList.Columns.Count + 1
If foundColumn > Columns.Count Then
MsgBox "We have run out of columns to put new Codes into!!" & vbCrLf
& _
"foundColumn value is now " & foundColumn & vbCrLf & _
"the new code (foundCode) is " _
& Chr$(34) & foundCode & Chr$(34) & vbCrLf & _
"Row being processed on source sheet is " _
& anySourceEntry.Row & vbCrLf & _
"There is no choice but to stop processing now!", _
vbOKOnly + vbCritical, "No Room Left"
GoTo CleanupAndExit
End If
destSheet.Cells(1, foundColumn) = foundCode
'and rebuild the codeList
Set codeList = destSheet.Range("A1:" & _
destSheet.Range("A1").End(xlToRight).Address)
End If
'find the last entry on the current row on the
'source sheet and assume that it is the amount
destSheet.Cells(foundRow, foundColumn) = anySourceEntry.Offset(0, _
Columns.Count - anySourceEntry.Column).End(xlToLeft)
Next ' examine next entry on the source sheet
CleanupAndExit:
Set codeList = Nothing
Set sourceRange = Nothing
Set sourceSheet = Nothing
Set destRange = Nothing
Set destSheet = Nothing
End Sub
Chris said:
Thanks JLatham - extremely helpful code. However it keeps breaking at line 75:
destSheet.Cells(1, foundColumn) = foundCode
???Any ideas?
JLatham said:
Interesting problem in that you have several Codes (ABC, SGC, TAV and maybe
more?) and that on the source sheet you've got multiple columns containing
the associated amounts.
You do need to have the 2nd sheet set up with row 1 labeled like you show:
ID 1st name last name code1 code2 code3
Actually the way I have things set up you don't even have to put the codes
on the 2nd sheet, the code will add new ones as they are encountered.
Use the code below to solve your problem. To get the code into your
workbook, open it and press [Alt]+[F11] to enter the VBA Editor and and then
using its menu, choose Insert | Module and then copy the code below and paste
it into the provided module. If you need to change the name(s) of the sheets
involved, do so in the copied code.
You can then run the macro from Excel's Tools | Macro | Macros menu choices.
It doesn't matter what sheet you have selected when you run it - it will run
properly no matter what sheet in the workbook is selected when you elect to
run it.
Sub CombineData()
Dim sourceSheet As Worksheet
Const SourceSheetName = "Sheet1" ' change if required
Dim sourceRange As Range ' for list of IDs
Dim anySourceEntry As Range ' individual ID entry
Dim destSheet As Worksheet
Const DestSheetName = "Sheet2" ' change if required
Dim destRange As Range ' for list of IDs
Dim anyDestEntry As Range ' individual ID entry
Dim codeList As Range ' labels on row 1 on dest sheet
Dim anyCodeEntry ' individual labels
Dim foundRow As Long
Dim foundColumn As Integer
Dim foundCode As String
Dim baseCell As Range ' for entries on destSheet
Set sourceSheet = ThisWorkbook.Worksheets(SourceSheetName)
Set sourceRange = sourceSheet.Range("A2:" & _
sourceSheet.Range("A" & Rows.Count).End(xlUp).Address)
Set destSheet = ThisWorkbook.Worksheets(DestSheetName)
Set codeList = destSheet.Range("A1:" & _
destSheet.Range("A1").End(xlToRight).Address)
Set sourceRange = sourceSheet.Range("A2:" & _
sourceSheet.Range("A" & Rows.Count).End(xlUp).Address)
For Each anySourceEntry In sourceRange
'must determine destRange each time thru the loop
Set destRange = destSheet.Range("A1:" & _
destSheet.Range("A" & Rows.Count).End(xlUp).Address)
foundRow = 0
For Each anyDestEntry In destRange
If anyDestEntry = anySourceEntry Then
foundRow = anyDestEntry.Row
Exit For
End If
Next
If foundRow = 0 Then
'a new entry, set up to add to bottom
'of the destination sheet list
foundRow = destSheet.Range("A" & Rows.Count).End(xlUp). _
Offset(1, 0).Row
End If
Set baseCell = destSheet.Range("A" & foundRow)
'here we keep from overwriting previously found
'ID and name so 1st one found is always used
If IsEmpty(baseCell) Then
'new entry, put the info on the sheet
'the ID number
baseCell = anySourceEntry
'the first name
baseCell.Offset(0, 1) = anySourceEntry.Offset(0, 1)
'the last name
baseCell.Offset(0, 2) = anySourceEntry.Offset(0, 2)
End If
'get the Code for the found item
foundCode = UCase(Trim(anySourceEntry.Offset(0, 3)))
'look through the labels on dest sheet for the code
For Each anyCodeEntry In codeList
foundColumn = 0 ' in case we don't match one
If UCase(Trim(anyCodeEntry)) = foundCode Then
foundColumn = anyCodeEntry.Column
Exit For
End If
Next
If foundColumn = 0 Then
'was a no match, put out in empty column
foundColumn = codeList.Columns.Count + 1
destSheet.Cells(1, foundColumn) = foundCode
'and rebuild the codeList
Set codeList = destSheet.Range("A1:" & _
destSheet.Range("A1").End(xlToRight).Address)
End If
'find the last entry on the current row on the
'source sheet and assume that it is the amount
destSheet.Cells(foundRow, foundColumn) = anySourceEntry.Offset(0, _
Columns.Count - anySourceEntry.Column).End(xlToLeft)
Next ' examine next entry on the source sheet
Set sourceRange = Nothing
Set sourceSheet = Nothing
Set destRange = Nothing
Set destSheet = Nothing
End Sub
Chris said:
Hi
I have a worksheet that I need to change into a different order and merge
data for same people (based on unique ID) into one line.
An example might help explain what I'm trying to achieve. I have the
following columns/titles:
Column A Column B Column C Column D Column E Column F
ID 1st name Surname Code Amount 1
Amount 2
1 Bob Smith SGC
20.00
1 Bob Smith TAV 25.00
2 John Jones ABC
40.00
Now, I need to reorder and merge data so that I only have 1 line for each
person in a new worksheet based on the 'Code' so that:
Column A Column B Column C Column D Column E Column F
ID 1st name Surname SGC TAV
ABC
1 Bob Smith 20.00 25.00
2 John Jones
40.00
Any ideas how this can be done???? I'm stumped.
Thanks
Chris
