Перенести строки из одной таблицы в другую по признаку

Скачать Со второго на первый при совпадении
Option Explicit
 
' https://www.youtube.com/channel/UCQMbRhaPEFD1NoZLhRzQzSA/videos?view=0&shelf_id=0&sort=dd
' https://inexsu.wordpress.com
 
Private ws_Sour As Worksheet
Private ws_Dest As Worksheet
Private d2_Sour() As Variant
Private d2_Dest() As Variant
 
Public Sub Squadra_Unita(Optional ByVal msg As Variant) _
 
' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=111261&TITLE_SEO=111261-poisk-po-znacheniyu-i-kopirovaniya-danykh&tags=%D0%A1%D1%83%D0%BC%D0%BC%D0%95%D1%81%D0%BB%D0%B8
 
    'Тестом НЕ покрыта
 
    Массив_Вставить _
            Проход_Массив_Назначение( _
            Массив_Назначение( _
            Массив_Источник( _
            Настройка)))
End Sub
 
Public Function Массив_Вставить(Optional ByVal msg As Variant) As Variant  '   Тестом НЕ покрыта
    Вставить_на_Лист d2_Dest, ws_Dest.Cells(2, 1)
End Function
 
Public Function Проход_Массив_Назначение(Optional ByVal msg As Variant) _
       As Variant  '   Тестом НЕ покрыта
 
    Dim y As Long, y_Sour As Long
    For y = LBound(d2_Dest) To UBound(d2_Dest)
 
        y_Sour = _
        в_Массиве(d2_Sour, 1, d2_Dest(y, 1))
 
        Массивы_Строку_Скопировать _
                d2_Sour, y_Sour, d2_Dest, y
 
    Next
End Function
 
Public Function Массивы_Строку_Скопировать( _
       d2_Sour() As Variant, ByVal y_Sour As Long, _
       d2_Dest() As Variant, ByVal y_Dest As Long) As Variant  '   Тестом НЕ покрыта
' массивы скопировать строку из одного в другой
 
    If y_Sour < LBound(d2_Sour, 2) Then _
       Exit Function
 
    Dim x As Long
    For x = LBound(d2_Sour, 2) To UBound(d2_Sour, 2)
        d2_Dest(y_Dest, x) = d2_Sour(y_Sour, x)
    Next
End Function
 
Public Function в_Массиве(d2() As Variant, _
                          ByVal iCol As Variant, _
                          ByVal str As String) _
                          As Long    ' Тестом НЕ покрыта
    Dim y As Long
    For y = LBound(d2) To UBound(d2)
        If d2(y, iCol) = str Then
            в_Массиве = y
            Exit For
        End If
    Next
 
    If y > UBound(d2) Then _
       в_Массиве = 0
 
End Function
 
Public Function Массив_Назначение(Optional ByVal msg As Variant) As Variant  '   Тестом НЕ покрыта
    d2_Dest = ws_Dest.UsedRange.Value
    ' расширяю ппо столбцам до исходного
    ReDim Preserve d2_Dest(1 To UBound(d2_Dest), _
                           1 To UBound(d2_Sour, 2))
End Function
 
Public Function Массив_Источник(Optional ByVal msg As Variant) As Variant  '   Тестом НЕ покрыта
    d2_Sour = ws_Sour.UsedRange.Value
End Function
 
Public Function Настройка(Optional ByVal msg As Variant) As Variant  '   Тестом НЕ покрыта
 
    Dim wb As Workbook: Set wb = ActiveWorkbook
    Set ws_Sour = wb.Worksheets("Лист2")
    Set ws_Dest = wb.Worksheets("Лист1")
 
End Function
 
Public Function Вставить_на_Лист(d2() As Variant, rng As Range) As Variant
 
' массив Вставить_на_Лист на лист 2 мерные
 
    rng.Resize(UBound(d2), UBound(d2, 2)) = d2
 
End Function