基于标题匹配的VBA复制和粘贴

Question

我编写了这段代码，以根据匹配的 ID 号将值从 Worksheet1 复制到 Worksheet2。我想通过在不使用 Offset(,3) 将值粘贴到距原始 ID 号 3 列的情况下也能够识别需要将数据粘贴到哪一列来提高效率。我在我的两个工作表中都使用了偏移量。

我现在有这个，

Set lkp = ws_Worksheet2.Range(ws_Worksheet2.Cells(6, 2), ws_Worksheet2.Cells(1235, 2).End(xlUp))
Set rng1 = ws_Worksheet1.Range(ws_Worksheet1.Cells(2, 1), ws_Worksheet1.Cells(1235, 1).End(xlUp))

For Each cll In lkp.Rows

    On Error Resume Next
    
    temp_var = cll.Value
    Set fnd = rng1.Find(What:=cll.Value, LookAt:=xlWhole)
    On Error GoTo 0
    
    If Not fnd Is Nothing Then
    
        cll.Offset(, 10).Value = fnd.Offset(, 1).Value
        cll.Offset(, 18).Value = fnd.Offset(, 2).Value
        cll.Offset(, 21).Value = fnd.Offset(, 9).Value
        cll.Offset(, 24).Value = fnd.Offset(, 3).Value
        cll.Offset(, 25).Value = fnd.Offset(, 4).Value
        cll.Offset(, 28).Value = fnd.Offset(, 8).Value 
        
    End If
Next cll

Answer 1

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