Как объединить с продолжением 2 таблицы между собой?

Sub Sortirovka_Parallelnaya()
    Dim i&, j&, LastRowA&, LastRowB&, A, B, Kontr$, DicA, DicB, DicC, vX
    Set DicA = CreateObject("Scripting.Dictionary")
    Set DicB = CreateObject("Scripting.Dictionary")
    Set DicC = CreateObject("Scripting.Dictionary")
    DicA.CompareMode = 1: DicB.CompareMode = 1: DicC.CompareMode = 1
    With ActiveSheet
        LastRowA = .Cells(.Rows.Count, 4).End(xlUp).Row
        LastRowB = .Cells(.Rows.Count, 9).End(xlUp).Row
        A = .Range("A3:G" & LastRowA).FormulaR1C1
        B = .Range("I3:L" & LastRowB).FormulaR1C1
        For i = 1 To UBound(A, 1)
            A(i, 4) = Trim(A(i, 4))
            If A(i, 4) <> "" Then DicA(A(i, 4)) = i: DicC(A(i, 4)) = 0&
        Next i
        For i = 1 To UBound(B, 1)
            B(i, 1) = Trim(B(i, 1))
            If B(i, 1) <> "" Then DicB(B(i, 1)) = i: DicC(B(i, 1)) = 0&
        Next i
        i = 2
        .[A3:L3].Copy
        .Range("A4:L" & DicC.Count + 2).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
        .Range("A3:L" & DicC.Count + 2).ClearContents
        For Each vX In DicC.Keys
            i = i + 1
            .Cells(i, 4) = vX
        Next vX
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:= _
            Range(Cells(3, 4), Cells(DicC.Count + 2, 4)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
            :=xlSortTextAsNumbers
            .SetRange Range(Cells(3, 4), Cells(DicC.Count + 2, 4))
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For i = 3 To DicC.Count + 2
            Kontr = .Cells(i, 4)
            If DicA.Exists(Kontr) Then
                For j = 1 To UBound(A, 2)
                    .Cells(i, j) = A(DicA(Kontr), j)
                Next j
            End If
            If DicB.Exists(Kontr) Then
                For j = 1 To UBound(B, 2)
                    .Cells(i, 8 + j) = B(DicB(Kontr), j)
                Next j
            End If
        Next i
    End With
    Set DicA = Nothing: Set DicB = Nothing: Set DicC = Nothing
End Sub