Excel VBA：跨文件按类型匹配 按指定规则拼接多行列数据

使用前请先备份两个Excel文件，避免意外数据丢失

操作步骤 #

1. 打开两个待处理的Excel文件
2. 按Alt+F11打开VBA编辑器，插入新模块：右键点击任意工作簿→插入→模块
3. 将下方代码粘贴到模块中，按需修改参数后按F5运行即可

VBA代码 #

Sub 批量匹配拼接内容()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim dict As Object
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, key As String, content As String
    
    ' 请修改下方参数为你实际的文件名和工作表名
    Set wb1 = Workbooks("文件1.xlsx")
    Set wb2 = Workbooks("文件2.xlsx")
    Set ws1 = wb1.Sheets("Sheet1")
    Set ws2 = wb2.Sheets("Sheet1")
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 读取文件2数据存入字典
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    ' 假设第1行为表头，从第2行开始读取，可按需修改起始行号
    For i = 2 To lastRow2
        key = Trim(ws2.Cells(i, "A").Value)
        ' 跳过B列包含冒号的行
        If InStr(1, ws2.Cells(i, "B").Value, ":", vbTextCompare) = 0 Then
            content = ws2.Cells(i, "B").Value & "[" & ws2.Cells(i, "C").Value & "]" & ws2.Cells(i, "D").Value
            If dict.Exists(key) Then
                dict(key) = dict(key) & vbCrLf & content
            Else
                dict(key) = content
            End If
        End If
    Next i
    
    ' 匹配结果写入文件1
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow1
        key = Trim(ws1.Cells(i, "A").Value)
        If dict.Exists(key) Then
            ws1.Cells(i, "B").Value = dict(key)
            ' 自动开启单元格换行适配内容
            ws1.Cells(i, "B").WrapText = True
        Else
            ' 无匹配时B列留空，可按需修改为其他默认值
            ws1.Cells(i, "B").Value = ""
        End If
    Next i
    
    ' 释放对象
    Set dict = Nothing
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set wb1 = Nothing
    Set wb2 = Nothing
    
    MsgBox "处理完成！"
End Sub

注意事项 #

• 代码默认第一行为表头，若你的数据从第1行开始，将两处循环的起始行号2修改为1即可
• 十万行以内数据处理耗时通常不超过10秒，远高于手动操作和普通公式计算效率
• 若运行提示找不到文件，确认两个文件都处于打开状态，且文件名和代码中填写的完全一致

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