VBA跨工作簿匹配复制代码修复：避免删除无匹配项的现有数据

问题根源 #

你的代码之所以会清空未匹配行的原有数据，是因为遍历目标表时，无论是否找到匹配项，都对目标列执行了赋值操作——未找到匹配时会将目标列设为空或清空内容，覆盖了原有数据。

核心修复逻辑 #

仅当在源表中找到目标行的匹配值时，才更新目标列的内容；未找到匹配时，跳过赋值操作，保留目标列原有数据。

修复后的基础版代码 #

Sub MatchAndCopyData()
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRowSource As Long, lastRowTarget As Long
    Dim i As Long, j As Long
    Dim matchFound As Boolean
    
    ' 替换为实际的工作簿和工作表名称
    Set wbSource = Workbooks("Book2.xlsm")
    Set wsSource = wbSource.Worksheets("Sheet1")
    Set wbTarget = Workbooks("Book1.xlsm")
    Set wsTarget = wbTarget.Worksheets("Sheet1")
    
    ' 获取两表数据区域的最后行号（匹配列设为A列，可按需修改）
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历目标表数据行（假设第1行为表头，从第2行开始）
    For i = 2 To lastRowTarget
        matchFound = False
        ' 在源表中查找匹配值
        For j = 2 To lastRowSource
            If wsTarget.Cells(i, "A").Value = wsSource.Cells(j, "A").Value Then
                ' 复制源表指定列到目标表对应列（示例：源B→目标C，源C→目标D）
                wsTarget.Cells(i, "C").Value = wsSource.Cells(j, "B").Value
                wsTarget.Cells(i, "D").Value = wsSource.Cells(j, "C").Value
                matchFound = True
                Exit For ' 找到匹配后退出源表循环，提升效率
            End If
        Next j
        
        ' 移除原代码中未匹配时的清空逻辑，保留原有数据
    Next i
    
    ' 释放对象
    Set wsSource = Nothing: Set wbSource = Nothing
    Set wsTarget = Nothing: Set wbTarget = Nothing
    
    MsgBox "数据更新完成！"
End Sub

高效优化版（大数据量推荐） #

如果数据量较大，嵌套循环效率较低，可改用Application.Match快速查找，代码更简洁高效：

Sub MatchAndCopyData_Optimized()
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRowSource As Long, lastRowTarget As Long
    Dim i As Long, matchRow As Variant
    
    ' 替换为实际的工作簿和工作表名称
    Set wbSource = Workbooks("Book2.xlsm")
    Set wsSource = wbSource.Worksheets("Sheet1")
    Set wbTarget = Workbooks("Book1.xlsm")
    Set wsTarget = wbTarget.Worksheets("Sheet1")
    
    ' 获取最后行号
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历目标表数据行
    For i = 2 To lastRowTarget
        ' 用Match函数快速查找匹配行（匹配列设为A列）
        matchRow = Application.Match(wsTarget.Cells(i, "A").Value, wsSource.Range("A2:A" & lastRowSource), 0)
        
        ' 仅找到匹配时更新数据
        If Not IsError(matchRow) Then
            ' 复制指定列（注意：Match返回的是相对位置，需+1对应源表实际行号）
            wsTarget.Cells(i, "C").Value = wsSource.Cells(matchRow + 1, "B").Value
            wsTarget.Cells(i, "D").Value = wsSource.Cells(matchRow + 1, "C").Value
        End If
        ' 未找到匹配时不做操作，保留原有数据
    Next i
    
    ' 释放对象
    Set wsSource = Nothing: Set wbSource = Nothing
    Set wsTarget = Nothing: Set wbTarget = Nothing
    
    MsgBox "数据更新完成！"
End Sub

关键改动说明 #

1. 移除未匹配清空逻辑：删除原代码中“未找到匹配时清空目标列”的代码块，确保未匹配行的原有数据不被修改。
2. 增加匹配标记（基础版）：用matchFound变量记录是否找到匹配，避免不必要的循环。
3. 改用快速查找（优化版）：Application.Match比嵌套循环查找速度快数倍，适合大数据量场景。

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