Sub test1()
'   ----------------------------
    Dim arr(), dic As Object
    Dim i&, j&, x&
'   ----------------------------
    
    Set dic = CreateObject("Scripting.Dictionary")
    ' заполняем словарь данными для проверки
    arr = ActiveSheet.UsedRange.Value
    For i = 1 To UBound(arr)
        If  dic.exists(CStr(arr(i, 1))) Then
            x = x + 1
            For j = 1 To UBound(arr, 2)
                arr(x, j) = arr(i, j)
            Next j
        End If
    Next i
    Worksheets(1).[a1].Resize(x, UBound(arr, 2)).Value = arr
End Sub

Sub test2()
'   ----------------------------
    Dim arr(), dic As Object
    Dim i&, j&, x&
'   ----------------------------
    
    Set dic = CreateObject("Scripting.Dictionary")
    ' заполняем словарь данными для проверки    
    arr = ActiveSheet.UsedRange.Value
    ReDim iarr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        If  dic.exists(CStr(arr(i, 1))) Then
            x = x + 1
            For j = 1 To UBound(arr, 2)
                iarr(x, j) = arr(i, j)
            Next j
        End If
    Next i
    Worksheets(1).[a1].Resize(x, UBound(arr, 2)).Value = iarr
End Sub

Sub test3()
'   ----------------------------
    Dim arr(), dic As Object
    Dim i&, j&, x&, iarr(), larr()
'   ----------------------------
    
    Set dic = CreateObject("Scripting.Dictionary")
    arr = ActiveSheet.UsedRange.Value
    ' заполняем словарь данными для проверки    
    For i = 1 To UBound(arr)
        If dic.exists(CStr(arr(i, 1))) Then
            x = x + 1
            ReDim Preserve iarr(1 To UBound(arr, 2), 1 To x)
            For j = 1 To UBound(arr, 2)
                iarr(j, x) = arr(i, j)
            Next j
        End If
    Next i
    ReDim larr(1 To UBound(iarr, 2), 1 To UBound(iarr))
    For i = 1 To UBound(iarr)
        For j = 1 To UBound(iarr, 2)
            larr(j, i) = iarr(i, j)
    Next j, i
    Worksheets(2).[a20].Resize(UBound(larr), UBound(larr, 2)).Value = larr
End Sub