Option Explicit
Sub CombineRows()
'
' http://www.excelguru.ca/forums/showthread.php?2551-Combining-several-rows-in-one
'
Dim rng As Range
Dim cel As Range
Dim WriteRow As Double
Dim Col3string As String
Dim pos As Long
Application.ScreenUpdating = False
'determine the range to work with
With Sheets("Sheet1")
'Set rng = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
'changed due to desired results using col A
Set rng = .Range("A2:A" & .Range("A2").End(xlDown).Row)
End With
'cycle through the cells in rng
For Each cel In rng
'if the cel value does not match a value on sheet 2 then add it
On Error Resume Next
If IsError(Application.WorksheetFunction.Match(cel.Value, Sheets("Sheet2").Range("A:A"), 0)) Then
'no match
WriteRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row + 1
'copy the row from sheet 1
cel.Resize(1, 4).Copy Sheets("Sheet2").Range("A" & WriteRow)
Else
'there is a match, so add to what exists in the cell in the column
'the row being dealt with
WriteRow = Application.WorksheetFunction.Match(cel.Value, Sheets("Sheet2").Range("A:A"), 0)
'add info for column B
Sheets("Sheet2").Range("B" & WriteRow).Value = Sheets("Sheet2").Range("B" & WriteRow).Value & Chr(10) & cel.Offset(0, 1).Value
'need to check if current info already exists in the column C row
Col3string = Sheets("Sheet2").Range("C" & WriteRow).Value
'starting position of string in string
pos = InStr(Col3string, cel.Offset(0, 2).Value)
'if position <> 0 then already exists
If pos = 0 Then
'add to the string
Sheets("Sheet2").Range("C" & WriteRow).Value = Sheets("Sheet2").Range("C" & WriteRow).Value & Chr(10) & cel.Offset(0, 2).Value
End If
End If
On Error GoTo 0
Next cel
Application.ScreenUpdating = True
End Sub