基于Product ID匹配的跨Excel工作表VBA数据有序复制问题求助

• 有两个Excel文件：《Sales report》和《Raw data》
• 需基于Product ID将《Raw data》的数据按对应列序复制到《Sales report》中
• 仅处理《Sales report》已有的4个Product ID对应的数据，两文件列顺序不同

Raw data（第一行为Excel默认列名，第二行为自定义表头） #

A             B       C          D          E                 F             G            H
Product ID    Store   StoreID    Quantity   Price per unit    Total price   CustomerID   Month 
AB001         NY      01         2          5                 10            A135324      04/2023
GHI001        SE      07         1          15                15            Z457246      07/2023
ACA001        CH      03         6          10                60            H293847      06/2023
JF001         OH      02         1          30                30            L293720      03/2023
SSF001        NY      01         8          20                160           B725183      06/2023
BI001         NY      01         2          25                50            J347346      04/2023
LA001         CO      09         3          4                 12            D346435      07/2023
OP001         SE      07         1          250               250           J959942      05/2023
RH001         OH      02         2          3                 6             A562450      04/2023
KQ001         NY      01         10         12                120           C662036      06/2023  

《Sales report》最终格式：

A             B        C            D       E          F                 G            H
Product ID    Month    CustomerID   Store   StoreID    Price per unit    Quantity     Total price
AB001         04/2023  A135324      NY      01         5                 2            10
OP001         05/2023  J959942      SE      07         250               1            250
ACA001        06/2023  H293847      CH      03         10                6            60
KQ001         06/2023  C662036      NY      01         12                10           120

Sub Main_content()
    
    Dim ws_copy As Worksheet
    Dim ws_paste As Worksheet
    Dim LastRow As Long
    Dim i As Long
    
    Workbooks.Open "C:\HP\Users\Downloads\Raw data.xlsx.xlsx"
    
    Set ws_copy = Workbooks("Raw data.xlsx").Sheets("sheet1")
    Set ws_paste = Workbooks("Sales report.xlsx").Sheets("sheet1")
    
    With ws_copy
      LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row
    End With

    For i = 2 To LastRow
        With ws_copy
            On Error Resume Next
            If WorksheetFunction.Match(ws_copy.Range("A" & i), ws_paste.Range("A:A"), 0) <> 0 Then
                .Cells(i, "B").Copy Destination:=ws_paste.Range("D" & i)
                .Cells(i, "C").Copy Destination:=ws_paste.Range("E" & i)
                .Cells(i, "D").Copy Destination:=ws_paste.Range("G" & i)
                .Cells(i, "E").Copy Destination:=ws_paste.Range("F" & i)
                .Cells(i, "F").Copy Destination:=ws_paste.Range("H" & i)
                .Cells(i, "G").Copy Destination:=ws_paste.Range("C" & i)
                .Cells(i, "H").Copy Destination:=ws_paste.Range("B" & i)
            Else
                .Cells(i, "A").EntireRow.Delete
            End If
        End With
    Next i
End Sub

原代码运行后所有10条数据都被粘贴到《Sales report》，部分Product ID对应错误，需要修正代码。

原代码问题分析 #

1. On Error Resume Next掩盖了Match函数找不到匹配项时的错误，导致Match返回错误值但代码仍执行If分支，所有数据都被粘贴
2. 粘贴时直接用循环变量i作为目标行号，没有匹配到《Sales report》中对应Product ID的实际行
3. 从前往后遍历删除行，会导致后续行索引错乱，出现漏删

修正代码 #

Sub Main_content()
    Dim ws_copy As Worksheet
    Dim ws_paste As Worksheet
    Dim lastRow_copy As Long
    Dim lastRow_paste As Long
    Dim i As Long
    Dim matchRow As Variant
    
    ' 打开Raw data文件（注意文件名后缀，原代码里是xlsx.xlsx，需确认实际文件名）
    Workbooks.Open "C:\HP\Users\Downloads\Raw data.xlsx"
    
    Set ws_copy = Workbooks("Raw data.xlsx").Sheets("sheet1")
    Set ws_paste = Workbooks("Sales report.xlsx").Sheets("sheet1")
    
    ' 获取Raw data的最后一行
    lastRow_copy = ws_copy.Cells(ws_copy.Rows.Count, "A").End(xlUp).Row
    ' 获取Sales report的最后一行（用于限定Match范围，提高效率）
    lastRow_paste = ws_paste.Cells(ws_paste.Rows.Count, "A").End(xlUp).Row
    
    ' 从后往前遍历，避免删除行导致索引错乱
    For i = lastRow_copy To 2 Step -1
        ' 查找当前Product ID在Sales report中的行号
        matchRow = Application.Match(ws_copy.Range("A" & i).Value, ws_paste.Range("A2:A" & lastRow_paste), 0)
        
        If Not IsError(matchRow) Then
            ' 找到匹配，计算Sales report中的目标行（A2开始，所以+1）
            Dim targetRow As Long
            targetRow = matchRow + 1
            
            ' 按列对应关系复制数据
            ws_paste.Range("B" & targetRow).Value = ws_copy.Range("H" & i).Value ' Month
            ws_paste.Range("C" & targetRow).Value = ws_copy.Range("G" & i).Value ' CustomerID
            ws_paste.Range("D" & targetRow).Value = ws_copy.Range("B" & i).Value ' Store
            ws_paste.Range("E" & targetRow).Value = ws_copy.Range("C" & i).Value ' StoreID
            ws_paste.Range("F" & targetRow).Value = ws_copy.Range("E" & i).Value ' Price per unit
            ws_paste.Range("G" & targetRow).Value = ws_copy.Range("D" & i).Value ' Quantity
            ws_paste.Range("H" & targetRow).Value = ws_copy.Range("F" & i).Value ' Total price
        Else
            ' 没找到匹配，删除Raw data中的该行
            ws_copy.Rows(i).Delete
        End If
    Next i
    
    ' 可选：保存并关闭Raw data文件
    ' Workbooks("Raw data.xlsx").Save
    ' Workbooks("Raw data.xlsx").Close
End Sub

修正要点 #

1. 用Application.Match替代WorksheetFunction.Match，结合IsError判断是否找到匹配，避免错误处理滥用
2. 计算《Sales report》中对应Product ID的实际行号，确保数据粘贴到正确位置
3. 从后往前遍历Raw data的行，删除行时不会打乱后续行的索引
4. 直接赋值替代Copy方法，提高运行效率（如果需要复制格式可保留Copy）

内容的提问来源于stack exchange，提问作者Laura