combine rows of data to one row...tough one

[Jeff]

Greetings -
I have a workbook in which I pull a bunch a data from another source. The
rows have the same name of a person, but each row has some small pieces that
are different (each in a seperate column). I would like to combine the
similiar people and their info into one row. For example, the data is now:

Hire Term Benefit Birth First Name Last Name
1/2/02 Jeff Jones
3/23/06 Jeff Jones
4/2/02 Jeff Jones
4/7 Jeff Jones
6/6/03 Barry Smith
10/6/03 Barry Smith
5/25/06 Barry Smith
10/4/04 Tom Jerid
12/4/0 Tom Jerid
1/23/06 Tom Jerid
6/12 Tom Jerid

And I would like for it to look like:

Hire Term Benefit Birth First Name Last Name
1/2/02 3/23/06 4/2/02 4/7 Jeff Jones
6/6/03 5/25/06 10/6/03 Barry Smith
9/4/04 1/23/06 10/4/04 6/12 Tom Jerid


I have tried everything and I am now officially stuck. Any help would be
great. Thank you.

 

[Greg Wilson]

Assumed is that the names are all first name / last name with no exceptions
such as single names or triple names. The code gets its reference from the
space preceeding the first name. An extra or missing space will screw it up.

Also assumed is that the data starts in cell A2 and continues to the last
datum in column A. The code tolerates gaps. So ensure there is nothing in
below the intended data.

The results will be pasted to column C starting at C2. Minimal testing.
Seems OK. I'm tired and off to bed. Good luck.

Sub CombineData()
Dim r As Range, c As Range
Dim i As Integer, x As Integer
Dim nm As String, currnm As String
Dim info As String, txt As String

Set r = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
i = 2
For Each c In r.Cells
txt = Trim(c.Value)
If Len(txt) > 0 Then
x = InStrRev(txt, " ")
x = InStrRev(txt, " ", x - 1)
nm = Right$(txt, Len(txt) - x)
If currnm <> nm Then
If Len(currnm) > 0 Then
Cells(i, 3) = info & " " & currnm
i = i + 1
End If
currnm = nm
info = Left$(txt, x - 1)
Else
info = info & " " & Left$(txt, x - 1)
End If
End If
Next
Cells(i, 3) = info & " " & currnm
Set c = Nothing: Set r = Nothing
End Sub

 

[Greg Wilson]

Sorry Jeff, I shouldn't have attempted this so late. I missed where you said
the data are in separate columns. On reading it in msdn, it appeared to all
be in a single column separated by spaces. If no one else solves it for you
I'll try again tomorrow night.

Greg

 

[Greg Wilson]

Assumed is that Hire/Term/Benefit/Birth/Last Name/First Name are in columns A
through F respectively. Results will be pasted to columns H through M. Set
the startrow constant to the desired start row. Here it is assumed to be row
2. Hope it's what you wanted. Minimal testing.


Const startrow As Integer = 2

Sub CombineData()
Dim r As Range, r2 As Range
Dim c As Range, c2 As Range
Dim i As Long, x As Long
Dim row1 As Long, row2 As Long, row3 As Long
Dim nm As String, currnm As String, txt As String

i = startrow: row1 = startrow: row2 = 0
Set r = Range(Cells(i, 6), Cells(Rows.Count, 6).End(xlUp)(2))
row3 = r(r.Rows.Count).Row
For Each c In r.Cells
txt = Trim(c.Value)
If Len(txt) > 0 Or c.Row = row3 Then
nm = Trim(c(1, 0).Value) & " " & txt
If currnm <> nm Then
If Len(currnm) > 0 Then
row2 = c.Row - 1
Set r2 = Range(Cells(row1, 1), Cells(row2, 4))
Set r2 = r2.SpecialCells(xlCellTypeConstants)
For Each c2 In r2.Cells
Cells(i, c2.Column + 7).Value = c2.Value
Next
Cells(i, 12).Value = c(0, 0).Value
Cells(i, 13).Value = c(0, 1).Value
i = i + 1
row1 = c.Row
End If
currnm = nm
End If
End If
Next
Set r = Nothing: Set r2 = Nothing
Set c = Nothing: Set c2 = Nothing
End Sub

Regards,
Greg