Sub AutoShape20_Щелчок()
    Dim rng As Range
    Set C_is = CreateObject("scripting.dictionary")
    With ThisWorkbook.Worksheets("данные")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("B1:F" & LastRow)
        For i = 1 To rng.Rows.Count
            Key = rng(i, 1).Offset(0, -1) & ""
            If Key <> "" Then
                Set C_is.Item(Key) = rng.Rows(i)
            End If
        Next
    End With
    With ThisWorkbook.Worksheets("реестр")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        dx = .Range("a1:a" & LastRow)
        .Range("g6:k" & LastRow).ClearContents
        For i = 6 To UBound(dx)
            Key = dx(i, 1) & ""
            If Key <> "" Then
                If C_is.Exists(Key) Then
                    C_is.Item(Key).Copy .Range("g" & i)
                End If
            End If
        Next
    End With
End Sub

Sub Test()
    Dim i&, y&, a(), b(), c()
    With Sheets("данные")
        a = .Range("A5:F" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    With Sheets("реестр")
        b = .Range("A6:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    ReDim c(1 To UBound(b), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            .Item(a(i, 1)) = i
        Next
        
        For i = 1 To UBound(b)
            If .Exists(b(i, 1)) Then
                For y = 1 To 5
                    c(i, y) = a(.Item(b(i, 1)), y + 1)
                Next
            End If
        Next
    End With
    With Sheets("реестр")
        .Range("G6:K" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
        .[g6].Resize(i - 1, 5).Value = c
    End With
End Sub