VBA查找：按标题显示不相邻的返回列

资料来源

目的地

Option Explicit

Sub LookupDataTitles()

    ' Define constants.
    Const SRC_NAME As String = "Export"
    Const SRC_HEADER_ROW As Long = 1
    Const DST_NAME As String = "Prepare"
    Const DST_HEADER_ROW As Long = 5
    Const LOOKUP_TITLE As String = "ID"
    Const RETURN_TITLES As String = "Name,Last Name,Quarter,Group,Sales,Count"
    
    Dim ReturnCols() As String: ReturnCols = Split(RETURN_TITLES, ",")
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Adjust if it's not!!!
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    Dim shrg As Range: Set shrg = sws.Rows(SRC_HEADER_ROW)
    Dim slCol As Long: slCol = Application.Match(LOOKUP_TITLE, shrg, 0)
    Dim slrg As Range
    With shrg.Cells(slCol).Offset(1)
        Set slrg = sws.Range(.Cells, sws.Cells(sws.Rows.Count, .Column).End(xlUp))
    End With
    Dim srCols(): srCols = Application.Match(ReturnCols, shrg, 0)
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    Dim dhrg As Range: Set dhrg = dws.Rows(DST_HEADER_ROW)
    Dim dlCol As Long: dlCol = Application.Match(LOOKUP_TITLE, dhrg, 0)
    Dim dlrg As Range
    With dhrg.Cells(dlCol).Offset(1)
        Set dlrg = dws.Range(.Cells, dws.Cells(dws.Rows.Count, .Column).End(xlUp))
    End With
    Dim drCols(): drCols = Application.Match(ReturnCols, dhrg, 0)
    
    ' Get the matching row indexes.
    Dim cCount As Long: cCount = UBound(drCols)
    Dim srIndexes(): srIndexes = Application.Match(dlrg, slrg, 0)
    
    Dim srg As Range, drg As Range, sr As Long, dr As Long, c As Long
    
    ' Write the matches.
    For dr = 1 To UBound(srIndexes)
        If IsNumeric(srIndexes(dr, 1)) Then
            sr = srIndexes(dr, 1)
            Set srg = shrg.Offset(sr)
            Set drg = dhrg.Offset(dr)
            For c = 1 To cCount
                drg.Columns(drCols(c)).Value = srg.Columns(srCols(c)).Value
            Next c
        End If
    Next dr
    
    MsgBox "Data lookup finished.", vbInformation

End Sub