基于匹配条件合并两个数据集的VBA代码问题求助

我懂你现在的困扰——之前写的VBA只能处理两个表col_1匹配的情况，但凡两边值不相等，独有的行就没法正确追加到结果表里。咱们重新梳理逻辑，写个能覆盖所有场景的代码。

首先明确核心逻辑：

• 先找出表1和表2中col_1匹配的行，提取表1的col_1、col_2、col_3和表2的col_3到结果表
• 再把表1中col_1不在表2里的独有行追加到结果表
• 最后把表2中col_1不在表1里的独有行追加到结果表

完整VBA代码实现 #

Sub MergeTables()
    Dim wsTable1 As Worksheet, wsTable2 As Worksheet, wsResult As Worksheet
    Dim dictTable1 As Object, dictTable2 As Object
    Dim lastRow1 As Long, lastRow2 As Long, resultRow As Long
    Dim i As Long, key As Variant
    
    ' 替换为你的实际工作表名称
    Set wsTable1 = ThisWorkbook.Sheets("表1")
    Set wsTable2 = ThisWorkbook.Sheets("表2")
    Set wsResult = ThisWorkbook.Sheets("结果表")
    
    ' 初始化字典，用于快速查找col_1的值
    Set dictTable1 = CreateObject("Scripting.Dictionary")
    Set dictTable2 = CreateObject("Scripting.Dictionary")
    
    ' 清空结果表并写入表头（可根据需求调整表头内容）
    wsResult.Cells.Clear
    wsResult.Range("A1:D1").Value = Array("col1", "col2", "col3_表1", "col3_表2")
    resultRow = 2 ' 从第2行开始写入数据
    
    ' 将表1数据存入字典：key为col_1值，item为(col2, col3)数组
    lastRow1 = wsTable1.Cells(wsTable1.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow1 ' 假设表头在第1行
        If Not IsEmpty(wsTable1.Range("A" & i).Value) Then
            Dim key1 As Variant
            key1 = wsTable1.Range("A" & i).Value
            If Not dictTable1.Exists(key1) Then
                dictTable1.Add key1, Array(wsTable1.Range("B" & i).Value, wsTable1.Range("C" & i).Value)
            End If
        End If
    Next i
    
    ' 将表2数据存入字典：key为col_1值，item为col3值
    lastRow2 = wsTable2.Cells(wsTable2.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow2 ' 假设表头在第1行
        If Not IsEmpty(wsTable2.Range("A" & i).Value) Then
            Dim key2 As Variant
            key2 = wsTable2.Range("A" & i).Value
            If Not dictTable2.Exists(key2) Then
                dictTable2.Add key2, wsTable2.Range("C" & i).Value
            End If
        End If
    Next i
    
    ' 第一步：处理col_1匹配的行
    For Each key In dictTable1.Keys
        If dictTable2.Exists(key) Then
            wsResult.Range("A" & resultRow).Value = key
            wsResult.Range("B" & resultRow).Value = dictTable1(key)(0) ' 表1的col2
            wsResult.Range("C" & resultRow).Value = dictTable1(key)(1) ' 表1的col3
            wsResult.Range("D" & resultRow).Value = dictTable2(key) ' 表2的col3
            resultRow = resultRow + 1
            dictTable2.Remove key ' 移除已匹配的key，方便后续处理独有行
        End If
    Next key
    
    ' 第二步：处理表1独有的行
    For Each key In dictTable1.Keys
        If Not dictTable2.Exists(key) Then
            wsResult.Range("A" & resultRow).Value = key
            wsResult.Range("B" & resultRow).Value = dictTable1(key)(0)
            wsResult.Range("C" & resultRow).Value = dictTable1(key)(1)
            wsResult.Range("D" & resultRow).Value = "" ' 表2无对应数据，留空
            resultRow = resultRow + 1
        End If
    Next key
    
    ' 第三步：处理表2独有的行
    For Each key In dictTable2.Keys
        wsResult.Range("A" & resultRow).Value = key
        wsResult.Range("B" & resultRow).Value = "" ' 表1无对应数据，留空
        wsResult.Range("C" & resultRow).Value = "" ' 表1无对应数据，留空
        wsResult.Range("D" & resultRow).Value = dictTable2(key)
        resultRow = resultRow + 1
    Next key
    
    MsgBox "合并完成！结果表共有 " & resultRow - 2 & " 条数据。", vbInformation
End Sub

代码说明 #

• 字典的优势：用字典快速查找col_1值，比嵌套循环效率高得多，尤其适合数据量大的场景
• 匹配行处理：遍历表1字典，找到表2中匹配的key后写入数据，同时移除表2字典的匹配key，避免重复处理
• 独有行处理：表1字典剩余的key就是独有的行，直接写入；表2字典剩余的key同理，没有对应数据的列留空（你可以根据需求修改留空逻辑，比如写入表2的col2，只需调整字典存储的内容即可）
• 注意事项：记得把代码中的工作表名称替换成你实际的表名，表头也可根据需求调整

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