Try
Sub test()
Dim a, i As Long, e, s, msg As String
a = Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 5)) Then
Set .Item(a(i, 5)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 5)).CompareMode = 1
End If
.Item(a(i, 5))(a(i, 7)) = .Item(a(i, 5))(a(i, 7)) + 1
Next
For Each e In .keys
If (.Item(e).Count = 1) * (.Item(e).items()(0) = 1) Then
.Remove e
End If
Next
If .Count > 0 Then
For i = 0 To .Count - 1
For Each s In .items()(i).keys
msg = msg & vbLf & s & " = " & .items()(i)(s)
Next
MsgBox msg, vbInformation, .keys()(i): msg = ""
If i <> .Count - 1 Then
If MsgBox("Continue?", vbQuestion) <> vbOK Then Exit For
End If
Next
End If
End With
End Sub
Bookmarks