Option Explicit
Option Base 1
Sub ДваТоварищаАга_InExSu()
Dim arr01(), arr02(), arr03()
Dim ub_arr01 As Long, ub_arr02 As Long, ub_arr03 As Long
Dim ub2_arr01 As Long, ub2_arr02 As Long, ub2_arr03 As Long
Dim i3NonBlank As Long
Dim i As Long, j As Long, k As Long
Dim str1 As String, str2 As String
Worksheets("Лист3").Cells.Clear
arr01() = Worksheets("Лист1").Range("a1").CurrentRegion.Value
arr02() = Worksheets("Лист2").Range("a1").CurrentRegion.Value
ub_arr01 = UBound(arr01, 1): ub_arr02 = UBound(arr02, 1):
ub2_arr01 = UBound(arr01, 2): ub2_arr02 = UBound(arr02, 2)
ub2_arr03 = ub2_arr01 + ub2_arr02 - 4
ReDim arr03(ub_arr01 + ub_arr02, _
    ub2_arr03)
    i3NonBlank = 1
For i = 1 To ub_arr01
    For j = 1 To ub_arr02
    str1 = arr01(i, 1) & arr01(i, 2) & arr01(i, 3) & arr01(i, 4)
    str2 = arr02(j, 1) & arr02(j, 2) & arr02(j, 3) & arr02(j, 4)
    If StrComp(str1, str2) = 0 Then
        For k = 1 To ub2_arr03
        If k <= ub2_arr01 Then
            arr03(i3NonBlank, k) = arr01(i, k)
        Else
            arr03(i3NonBlank, k) = arr02(i, k - 2)  ' разница столбцов
        End If
        Next
        i3NonBlank = i3NonBlank + 1
    End If
    Next
Next
With Worksheets("Лист3")
    .Cells.Clear
    .Range("a1").Resize(UBound(arr03), UBound(arr03, 2)) = arr03
    .Select
End With
End Sub

Sub ДваТоварищаАга_InExSu()

Dim arr01(), arr02(), arr03()
Dim ub_arr01 As Long, ub_arr02 As Long, ub_arr03 As Long
Dim ub2_arr01 As Long, ub2_arr02 As Long, ub2_arr03 As Long
Dim i3NonBlank As Long
Dim i As Long, j As Long, k As Long
Dim str1 As String, str2 As String
Worksheets("Лист3").Cells.Clear
arr01() = Worksheets("Лист1").Range("a1").CurrentRegion.Value
arr02() = Worksheets("Лист2").Range("a1").CurrentRegion.Value
ub_arr01 = UBound(arr01, 1): ub_arr02 = UBound(arr02, 1):
ub2_arr01 = UBound(arr01, 2): ub2_arr02 = UBound(arr02, 2)
ub2_arr03 = ub2_arr01 + ub2_arr02 - 4
ReDim arr03(ub_arr01 + ub_arr02, _
ub2_arr03)
i3NonBlank = 1
timeStart = Timer

For i = 1 To ub_arr01
For j = 1 To ub_arr02
If StrComp(arr01(i, 1) & arr01(i, 2) & arr01(i, 3) & arr01(i, 4), _
arr02(j, 1) & arr02(j, 2) & arr02(j, 3) & arr02(j, 4)) = 0 Then
For k = 1 To ub2_arr03
If k <= ub2_arr01 Then
arr03(i3NonBlank, k) = arr01(i, k)
Else
arr03(i3NonBlank, k) = arr02(i, k - 2) ' разница столбцов
End If
Next
i3NonBlank = i3NonBlank + 1
End If
Next j
DoEvents
'Call GetFor_By(i, ub_arr01)
Application.StatusBar = i & " из " & ub_arr01
Next i
Application.StatusBar = False
With Worksheets("Лист3")
.Cells.Clear
.Range("a1").Resize(UBound(arr03), UBound(arr03, 2)) = arr03
.Select
End With
MsgBox "Макрос ДваТоварищаАга_InExSu отработал", vbOKOnly Or vbInformation, "Завершение!"
End Sub

Sub Zagr()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Set sh1 = ThisWorkbook.Sheets("Лист1")
    With sh1
        r11_ = .Range("A" & .Rows.Count).End(3).Row
    End With
    Set sh2 = ThisWorkbook.Sheets("Лист2")
    With sh2
        r12_ = .Range("A" & .Rows.Count).End(3).Row
    End With
    Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Clear
    Application.ScreenUpdating = 0
    Application.Calculation = xlCalculationManual
    sh1.Range("A1").Resize(r11_, 6).Copy
    Range("A1").PasteSpecial (xlPasteAll)
    Range("AA" & r12_ + 1).PasteSpecial (xlPasteAll)
    sh2.Range("A1").Resize(r12_, 4).Copy
    Range("A" & r11_ + 1).PasteSpecial (xlPasteAll)
    Range("AA1").PasteSpecial (xlPasteAll)
    sh2.Range("E1").Resize(r12_, 3).Copy
    Range("G" & r11_ + 1).PasteSpecial (xlPasteAll)
    Range("AG1").PasteSpecial (xlPasteAll)
    n_ = r11_ + r12_
    With Me.Sort.SortFields
        .Clear
        .Add Key:=Range("A1:A" & n_)
        .Add Key:=Range("B1:B" & n_)
        .Add Key:=Range("C1:C" & n_)
        .Add Key:=Range("D1:D" & n_)
    End With
    With Me.Sort
        .SetRange Range("A1:I" & n_)
        .Apply
    End With
    With Me.Sort.SortFields
        .Clear
        .Add Key:=Range("AA1:AA" & n_)
        .Add Key:=Range("AB1:AB" & n_)
        .Add Key:=Range("AC1:AC" & n_)
        .Add Key:=Range("AD1:AD" & n_)
    End With
    With Me.Sort
        .SetRange Range("AA1:AI" & n_)
        .Apply
    End With
    Range("AE1:AI2" & n_).Copy
    Range("E1").PasteSpecial Paste:=xlPasteAll, SkipBlanks:=True
    Range("AA1:AI2" & n_).Clear
    Range("A1").Resize(n_, 9).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo
    Range("a1").Select
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub