Daniel

For starts try this on a backup copy of your data


I hope I undersand what you are after correctly

Macro assums data is in column A to E with headers
Sorts data by Column B

starting at b2 it checks if data in B3 is the same
if it is then checks if data in C3 is already in B2
if no then adds C3 data to C2 and increase count by 1
then clears row 3 of data
Then repeats checking b2 against c4, c5 etc

if b2 not equal b3 moves on to check b3 against b4 etc



Sub Macro1()
Dim lRow As Long
Dim lStatRow As Long
Dim sTxt As String

'Selection.TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, _
Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1))

' Sort Data
Columns("A:E").Sort Key1:=Range("B2"), _
Order1:=xlAscending, Key2:=Range("A2"), _
Order2:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom


lStatRow = 2
For lRow = 2 To Cells(Rows.Count, "b").End(xlUp).Row Step 1
If Cells(lRow, "b").Value < "" Then
If Cells(lStatRow, "A") = 0 Then
Cells(lStatRow, "A") = 1
End If
If Cells(lRow, "b").Value = _
Cells(lStatRow, "b").Value Then
If InStr(1, Cells(lStatRow, "c").Value, _
Cells(lRow, "c").Value) = 0 Then
Cells(lStatRow, "c").Value = _
Cells(lStatRow, "c").Value _
& ", " & Cells(lRow, "c").Value
Cells(lStatRow, "a").Value = _
Cells(lStatRow, "a").Value + 1
Rows(lRow).ClearContents
End If
Else
lStatRow = lRow
End If
end if
Next lRow
End Su

--
Message posted from http://www.ExcelForum.com