Option Explicit
Sub TEST()
Dim lr&, i&, k&, col&, b1, b2, rng, res(1 To 10000, 1 To 2)
Dim dic As Object, key
Set dic = CreateObject("Scripting.Dictionary")
lr = WorksheetFunction.Max(Cells(Rows.Count, "A").End(xlUp).Row, Cells(Rows.Count, "D").End(xlUp).Row)
rng = Range("A3:E" & lr).Value
For i = 1 To UBound(rng)
If Not dic.exists(rng(i, 1)) Then
dic.Add rng(i, 1), "1|0"
Else
dic(rng(i, 1)) = Split(dic(rng(i, 1)), "|")(0) + 1 & "|" & Split(dic(rng(i, 1)), "|")(1)
End If
If Not dic.exists(rng(i, 4)) Then
dic.Add rng(i, 4), "0|1"
Else
dic(rng(i, 4)) = Split(dic(rng(i, 4)), "|")(0) & "|" & Split(dic(rng(i, 4)), "|")(1) + 1
End If
Next
For Each key In dic.keys
b1 = Split(dic(key), "|")(0): b2 = Split(dic(key), "|")(1)
For i = 1 To UBound(rng)
If b1 >= b2 Then col = 2 Else col = 5
If rng(i, col - 1) = key Then
k = k + 1: res(k, 1) = key: res(k, 2) = rng(i, col)
End If
Next
Next
Range("G3:H10000").ClearContents
Range("G3").Resize(k, 2).Value = res
End Sub
