VBA查找：复制列

Type Wks
    Name As String
    LookupColumn As Long
    FirstColumn As Long
End Type

Sub LookupData()
    
    Dim Src As Wks
    Src.Name = "Sheet2"
    Src.LookupColumn = 2
    Src.FirstColumn = 3
    
    Dim Dst As Wks
    Dst.Name = "Sheet1"
    Dst.LookupColumn = 2
    Dst.FirstColumn = 3
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read source.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(Src.Name)
    
    Dim srg As Range, slData() As Variant, srCount As Long, cCount As Long
    
    With sws.Range("A1").CurrentRegion
        srCount = .Rows.Count - 1
        cCount = .Columns.Count
        If srCount = 0 Then Exit Sub
        Set srg = .Resize(srCount).Offset(1)
    End With
    
    With srg.Columns(Src.LookupColumn)
        If srCount = 1 Then
            ReDim slData(1 To 1, 1 To 1): slData(1, 1) = .Value
        Else
            slData = .Value
        End If
    End With
    
    Dim cOffset As Long: cOffset = Src.FirstColumn - 1
    cCount = cCount - cOffset
    
    Dim svData() As Variant
    With srg.Resize(, cCount).Offset(, cOffset)
        If srCount * cCount = 1 Then
            ReDim svData(1 To 1, 1 To 1): svData = .Value
        Else
            svData = .Value
        End If
    End With
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim r As Long, cString As String
    
    For r = 1 To srCount
        cString = CStr(slData(r, 1))
        If Not dict.Exists(cString) Then dict(cString) = r
    Next r
    
    ' Read destination.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(Dst.Name)
    
    Dim drg As Range, dlData() As Variant, drCount As Long
    
    With dws.Range("A1").CurrentRegion
        drCount = .Rows.Count - 1
        If drCount = 0 Then Exit Sub
        Set drg = .Resize(drCount).Offset(1)
    End With
    
    With drg.Columns(Dst.LookupColumn)
        If drCount = 1 Then
            ReDim dlData(1 To 1, 1 To 1): dlData(1, 1) = .Value
        Else
            dlData = .Value
        End If
    End With
    
    Dim dvData() As Variant: ReDim dvData(1 To drCount, 1 To cCount)
    
    ' Lookup and write to destination.
    
    Dim dr As Long, c As Long
    
    For r = 1 To drCount
        cString = CStr(dlData(r, 1))
        If dict.Exists(cString) Then
            dr = dict(cString)
            For c = 1 To cCount
                dvData(r, c) = svData(dr, c)
            Next c
        End If
    Next r

    Dim dfCell As Range: Set dfCell = drg.Columns(Dst.FirstColumn).Cells(1)
    Dim dvrg As Range: Set dvrg = dfCell.Resize(drCount, cCount)
    
    dvrg.Value = dvData

    ' Inform.
    
    MsgBox "Data copied.", vbInformation

End Sub