If the macro is a must try
Option Explicit
Sub CollectData()
Dim WkRg As Range
Dim WkTb()
Dim ObjDic1 As Object
Dim ObjDic2 As Object
Dim I As Long
Dim Temp
Dim F
Set ObjDic1 = CreateObject("Scripting.Dictionary")
Set ObjDic2 = CreateObject("Scripting.Dictionary")
Set WkRg = Sheets("Cases_Out").Cells(1, 1).CurrentRegion
WkTb = WkRg
With ObjDic1
For I = 2 To UBound(WkTb, 1)
Temp = WkTb(I, 1) & "/" & WkTb(I, 2)
If (.exists(Temp)) Then
.Item(Temp) = .Item(Temp) + 1
Else
.Item(Temp) = 1
End If
Next I
For Each F In .keys
If (.Item(F) = 1) Then
Temp = Split(F, "/")
With ObjDic2
If (.exists(Temp(0))) Then
.Item(Temp(0)) = .Item(Temp(0)) + 1
Else
.Item(Temp(0)) = 1
End If
End With
End If
Next
End With
With ObjDic2
Sheets("Result").Cells.ClearContents
Sheets("Result").Range("A1").Resize(1, 2) = Array("Name", "Count")
Sheets("Result").Range("A2").Resize(.Count, 1) = Application.Transpose(.keys)
Sheets("Result").Range("B2").Resize(.Count, 1) = Application.Transpose(.items)
End With
End Sub
Bookmarks