Option Explicit
Sub MacroVer2()
Dim ws As Worksheet
Dim r As Range, r1 As Range
Dim i As Long
'init
Set ws = Worksheets("Output")
ws.Cells(1, 1).CurrentRegion.Clear
Worksheets("Sheet1").Cells(1, 1).CurrentRegion.Copy ws.Cells(1, 1)
Set r = ws.Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)
'sort by Country-Code-Commish = Cols ACD
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r1.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r1.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With r
For i = r.Rows.Count To 3 Step -1
'same country and code and commish
If (.Cells(i, 1).Value = .Cells(i - 1, 1).Value) And (.Cells(i, 2).Value = .Cells(i - 1, 2).Value) And (.Cells(i, 4).Value = .Cells(i - 1, 4).Value) Then
If InStr(.Cells(i - 1, 3).Value, .Cells(i, 3).Value) = 0 Then
.Cells(i - 1, 3).Value = .Cells(i - 1, 3).Value & "," & .Cells(i, 3).Value
.Rows(i).Delete
End If
End If
Next i
End With
Set r = ws.Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)
'sort by Country-level-Commish = Cols ABD
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r1.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With r
For i = r.Rows.Count To 3 Step -1
'same country and level and commish
If (.Cells(i, 1).Value = .Cells(i - 1, 1).Value) And (.Cells(i, 3).Value = .Cells(i - 1, 3).Value) And (.Cells(i, 4).Value = .Cells(i - 1, 4).Value) Then
If InStr(.Cells(i - 1, 2).Value, .Cells(i, 2).Value) = 0 Then
.Cells(i - 1, 2).Value = .Cells(i - 1, 2).Value & "," & .Cells(i, 2).Value
.Rows(i).Delete
End If
End If
Next i
End With
Set r = ws.Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)
'Final sort by Country-level-Code - Commish = Cols ABCD
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r1.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=r1.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
r.EntireColumn.AutoFit
MsgBox "All Done"
End Sub