Try this macro - I have assumed that the cell contents are values and not formulas.
Sub Macro1()
Dim c As Range
Dim a As Range
Dim r As Long
Dim f As Range
With Worksheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A:A"), Order:=xlAscending
.SortFields.Add Key:=Range("B:B"), Order:=xlAscending
.SetRange Range("A1").CurrentRegion
.Header = xlYes
.Orientation = xlTopToBottom
.Apply
End With
For r = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If Cells(r, "A").Value <> Cells(r - 1, "A").Value Then
Cells(r, "A").EntireRow.Insert
End If
Next r
For Each a In Range("A:A").SpecialCells(xlCellTypeConstants).Areas
For Each c In a.Offset(0, 1)
a.Offset(0, 2).Replace ", " & c.Value, ""
a.Offset(0, 2).Replace c.Value & ", ", ""
a.Offset(0, 2).Replace "," & c.Value, ""
a.Offset(0, 2).Replace c.Value & ",", ""
a.Offset(0, 2).Replace c.Value, ""
Next c
Next a
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Bookmarks