Option Explicit
Dim x

Sub ertert()
Dim y(), i&, k&, s$, r
Application.ScreenUpdating = False

x = Range("B1").CurrentRegion.Value
ReDim y(1 To 1000, 1 To UBound(x, 2))
ReDim r(1 To UBound(x, 2))

With CreateObject("Scripting.Dictionary")
      .CompareMode = 1
      For i = 1 To UBound(x, 2) Step 2
          .Item(x(1, i) & x(1, i + 1)) = i
      Next i

      Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга1.xlsx]Лист1'!A8:D10000)"
      For i = 1 To UBound(x)
          If IsEmpty(x(i, 2)) Then Exit For
          If Len(x(i, 1)) = 0 Then
              s = x(i, 2) & x(i, 3)
              If .Exists(s) Then k = .Item(s): r(k) = r(k) + 1: y(r(k), k) = x(i, 4)
          End If
      Next i

      Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга2.xlsx]Лист1'!D4:G10000)"
      For i = 1 To UBound(x)
          If IsEmpty(x(i, 2)) Then Exit For
          If Len(x(i, 1)) = 0 Then
              s = x(i, 2) & x(i, 3)
              If .Exists(s) Then k = .Item(s) + 1: r(k) = r(k) + 1: y(r(k), k) = x(i, 4)
          End If
      Next i
End With
Range("A1").Formula = Empty
Range("B3").Resize(UBound(y, 1), UBound(y, 2)).Value = y
Application.ScreenUpdating = True
End Sub

Private Function ToArray(ref)
x = ref
End Function

Option Explicit
Dim x

Sub ertert()
Dim y(), i&, k&, s$, r
Application.ScreenUpdating = False

x = Range("B1").CurrentRegion.Value
ReDim y(1 To 1000, 1 To UBound(x, 2))
ReDim r(1 To UBound(x, 2)): Range("A1").Formula = Empty

With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For i = 1 To UBound(x, 2) Step 2
         .Item(Trim(x(1, i)) & Trim(x(1, i + 1))) = i
     Next i

     Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга1.xlsx]Лист1'!A6:D10000)" 'данные начинаются с 6-й строки
     For i = 1 To UBound(x)
         If IsEmpty(x(i, 2)) Then Exit For
          
         ' If Len(x(i, 1)) = 0 Then'теперь условие для Книга1 не проверяем, т.е. его просто нет
         s = Trim(x(i, 2)) & Trim(x(i, 3))
         If .Exists(s) Then k = .Item(s): r(k) = r(k) + 1: y(r(k), k) = x(i, 4)
         ' End If
     Next i
      
     Range("A1").Formula = "=ToArray('" & ThisWorkbook.Path & "\[Книга2.xls]Лист1'!D4:G10000)" 'Книга2.xls - Книга2 оказалась в формате Ексель 2003
     For i = 1 To UBound(x)
         If IsEmpty(x(i, 2)) Then Exit For
         If Len(x(i, 1)) = 0 Then
             s = Trim(x(i, 2)) & Trim(x(i, 3)) 'везде добавляем Trim, т.к. какой-то коварный враг наставил пробелов в данных
             If .Exists(s) Then k = .Item(s) + 1: r(k) = r(k) + 1: y(r(k), k) = x(i, 4)
         End If
     Next i
End With
Range("A1").Formula = Empty
Range("B3").Resize(UBound(y, 1), UBound(y, 2)).Value = y
Application.ScreenUpdating = True
End Sub

Private Function ToArray(ref)
  x = ref
End Function