Sub XYZ()
Dim dicBD As Object, dBD As Object, dicKT As Object, dKT As Object
Dim arr(), res(), a, sRow&, i&
Set dicBD = CreateObject("scripting.dictionary")
Set dBD = CreateObject("scripting.dictionary")
Set dicKT = CreateObject("scripting.dictionary")
Set dKT = CreateObject("scripting.dictionary")
arr = Sheet1.Range("A2", Sheet1.Range("E" & Rows.Count).End(xlUp)).Value
sRow = UBound(arr)
ReDim res(1 To sRow, 1 To 6)
For i = 1 To sRow
Call AddDic(arr, dicBD, dBD, i, arr(i, 4))
Call AddDic(arr, dicKT, dKT, i, arr(i, 5))
Next i
Call AddRes(res, dicBD, 0)
Call AddRes(res, dicKT, 3)
Sheet1.Range("F2").Resize(sRow, 6) = res
End Sub
Private Sub AddDic(arr, dic, dic2, i, ByVal gio$)
Dim a, key$
If dic.exists(gio) = False Then
dic.Add gio, Array(0, 0, 0, i)
Else
a = dic(gio)
ReDim Preserve a(0 To UBound(a) + 1)
a(UBound(a)) = i
dic(gio) = a
End If
a = dic(gio)
key = arr(i, 3) & "|" & gio
If dic2.exists(key) = False Then
dic2.Add key, Empty
a(0) = a(0) + 1
End If
key = arr(i, 2) & "|" & gio
If dic2.exists(key) = False Then
dic2.Add key, Empty
a(1) = a(1) + 1
End If
key = arr(i, 1) & "|" & gio
If dic2.exists(key) = False Then
dic2.Add key, Empty
a(2) = a(2) + 1
End If
dic(gio) = a
End Sub
Private Sub AddRes(res, dic, ByVal dj&)
Dim a, j&, r&
For Each a In dic.items
For j = 3 To UBound(a)
r = a(j)
res(r, 1 + dj) = a(0)
res(r, 2 + dj) = a(1)
res(r, 3 + dj) = a(2)
Next j
Next a
End Sub
