Sub поиск()
LR1 = Cells(Rows.Count, 1).End(xlUp).Row
LR3 = Cells(Rows.Count, 3).End(xlUp).Row + 1
Dim arr, i
arr = Range(Cells(LR1, 1), Cells(LR3, 2)).Value
Dim newArr() As String, uniqArr
For i = 1 To UBound(arr)
      ReDim Preserve newArr(1 To i)
      newArr(i) = CStr(arr(i, 1) & "," & arr(i, 2))
Next
i = 1
      For Each v In UniqueValues(newArr())
          Debug.Print Split(v, ",")(0)
          Cells(i, 10) = Split(v, ",")(0)
          Cells(i, 11) = Split(v, ",")(1)
          Cells(i, 12) = Application.WorksheetFunction.CountIfs(Range(Cells(LR1, 1), Cells(LR3, 1)), Split(v, ",")(0), Range(Cells(LR1, 2), Cells(LR3, 2)), Split(v, ",")(1))
          i = i + 1
      Next
End Sub

Sub tt()
     Dim a(), i&

     With CreateObject("Scripting.Dictionary"): .comparemode = 1
         a = [a1].CurrentRegion.Value
         For i = 1 To UBound(a)
             If Len(Trim(a(i, 3))) = 0 Then .Item(a(i, 1) & "|" & a(i, 2)) = .Item(a(i, 1) & "|" & a(i, 2)) + 1
         Next
         Workbooks.Add(1).Sheets(1).[a1].Resize(.Count, 2) = Application.Transpose(Array(.keys, .items))
     End With

End Sub

Option Explicit

Sub tt()
      Dim a(), i&, t$, x&, y&

      With CreateObject("Scripting.Dictionary"): .comparemode = 1
          a = Sheets("исходник").[a1].CurrentRegion.Value 'должно быть не менее 5-ти столбцов!
          For i = 1 To UBound(a)
              If Len(Trim(a(i, 4))) = 0 Then
                  t = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 5)
                  If Not .exists(t) Then
                      x = x + 1: .Item(t) = x
                      a(x, 1) = a(i, 1)
                      a(x, 2) = a(i, 2)
                      a(x, 3) = a(i, 3)
                      a(x, 4) = 1
                      a(x, 5) = a(i, 5)
                  Else
                      y = .Item(t)
                      a(y, 4) = a(y, 4) + 1
                  End If
              End If
          Next
      End With
        
      With Sheets("результат")
          .[a1].CurrentRegion.Offset(2).ClearContents
          .[a3].Resize(x, 5) = a
      End With

End Sub