修改VBA代码：跨工作簿指定列匹配后精准写入数据

需求概述 #

对比Workbook A与Workbook B的指定列，当值匹配时，将Workbook A中另外两指定列的数据写入Workbook B对应匹配行的指定列。

原代码问题 #

原代码引入了多余的Workbook C，逻辑为将匹配行整行粘贴到新位置，无法满足「写入B对应匹配行指定列」的需求，同时存在语法错误（如Cl.Value未定义、Wbk对象未声明）。

修改后的代码 #

Sub MatchAndUpdate()
    Dim WbkA As Workbook, WbkB As Workbook
    Dim AryA As Variant, AryB As Variant
    Dim Dic As Object
    Dim r As Long, matchColA As Long, matchColB As Long
    Dim sourceCol1 As Long, sourceCol2 As Long
    Dim targetCol1 As Long, targetCol2 As Long
    
    ' 按需修改列索引，示例配置：
    matchColA = 5       ' Workbook A中用于匹配的列
    matchColB = 2       ' Workbook B中用于匹配的列
    sourceCol1 = 3      ' Workbook A中需提取的第一列
    sourceCol2 = 4      ' Workbook A中需提取的第二列
    targetCol1 = 6      ' Workbook B中写入的第一目标列
    targetCol2 = 7      ' Workbook B中写入的第二目标列
    
    ' 打开目标工作簿（确保文件路径正确，或改用GetOpenFilename手动选择）
    Set WbkA = Workbooks.Open(Application.DefaultFilePath & "\WorkbookA.xlsx")
    Set WbkB = Workbooks.Open(Application.DefaultFilePath & "\WorkbookB.xlsx")
    Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare ' 不区分大小写匹配，区分则改为vbBinaryCompare
    
    ' 将Workbook A的匹配键与对应数据存入字典
    With WbkA.Sheets(1)
        AryA = .Range("A2", .Cells(.Rows.Count, matchColA).End(xlUp)).Resize(, sourceCol2).Value2
        For r = 1 To UBound(AryA)
            If Not Dic.Exists(AryA(r, matchColA)) Then
                Dic(AryA(r, matchColA)) = Array(AryA(r, sourceCol1), AryA(r, sourceCol2))
            End If
        Next r
    End With
    
    ' 遍历Workbook B匹配列，匹配后写入指定列
    With WbkB.Sheets(1)
        AryB = .Range("A2", .Cells(.Rows.Count, matchColB).End(xlUp)).Resize(, targetCol2).Value2
        For r = 1 To UBound(AryB)
            If Dic.Exists(AryB(r, matchColB)) Then
                AryB(r, targetCol1) = Dic(AryB(r, matchColB))(0)
                AryB(r, targetCol2) = Dic(AryB(r, matchColB))(1)
            End If
        Next r
        ' 批量写回更新后的数据
        .Range("A2").Resize(UBound(AryB), UBound(AryB, 2)).Value2 = AryB
    End With
    
    ' 收尾操作
    WbkA.Close SaveChanges:=False
    WbkB.Close SaveChanges:=True
    Set Dic = Nothing
    Set WbkA = Nothing
    Set WbkB = Nothing
End Sub

代码说明 #

1. 灵活配置：开头的列索引变量可直接根据表格结构修改，无需改动核心逻辑
2. 高效匹配：用字典存储匹配键与对应数据，实现O(1)查询效率，适配大数据量场景
3. 数组优化：批量读写数组替代单元格操作，避免频繁IO，大幅提升运行速度
4. 精准写入：直接在Workbook B的数组中更新对应目标列，确保数据写入匹配行的指定位置

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