VBA实现两个CSV工作簿按邮箱匹配合并到主工作表

核心实现逻辑 #

• 自动读取指定路径下Fundraise-pages(1).csv、Supporters(1).csv两个文件的Sheet1全量数据
• 自动识别两个文件中的邮箱地址列，兼容Email、E-mail、邮箱等常见表头命名
• 主工作表左侧区域写入Fundraise文件全量数据（含表头），右侧空1列分隔后写入匹配到的Supporters文件对应全量数据（含表头）
• 仅保留两边邮箱一致的匹配记录，自动对齐行位置，无匹配的记录不会写入结果
• 运行前自动清空主表原有内容，避免旧数据干扰，运行完成后自动调整列宽

完整VBA代码 #

Sub MergeCSVByEmailMatch()
    Dim wbMain As Workbook, wbFund As Workbook, wbSupp As Workbook
    Dim wsMain As Worksheet, wsFund As Worksheet, wsSupp As Worksheet
    Dim lastRowFund As Long, lastRowSupp As Long, lastColFund As Long, lastColSupp As Long
    Dim emailColFund As Long, emailColSupp As Long, emailVal As String
    Dim i As Long, j As Long, matchRow As Long
    Dim dictSupp As Object
    Dim csvPath As String
    
    ' 关闭屏幕更新、弹窗提示提升运行效率
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 初始化主工作表，默认使用当前工作簿第1个工作表，可按需修改
    Set wbMain = ThisWorkbook
    Set wsMain = wbMain.Sheets(1)
    wsMain.Cells.Clear
    
    ' 配置CSV路径，默认和主工作簿同目录，可修改为自定义绝对路径
    csvPath = ThisWorkbook.Path & "\"
    ' 校验源文件是否存在
    If Dir(csvPath & "Fundraise-pages(1).csv") = "" Or Dir(csvPath & "Supporters(1).csv") = "" Then
        MsgBox "源CSV文件不存在，请确认文件放置路径后重试", vbExclamation
        GoTo Cleanup
    End If
    
    ' 只读方式打开两个源CSV文件
    Set wbFund = Workbooks.Open(Filename:=csvPath & "Fundraise-pages(1).csv", ReadOnly:=True)
    Set wsFund = wbFund.Sheets(1)
    Set wbSupp = Workbooks.Open(Filename:=csvPath & "Supporters(1).csv", ReadOnly:=True)
    Set wsSupp = wbSupp.Sheets(1)
    
    ' 自动识别Fundraise文件的邮箱列
    lastColFund = wsFund.Cells(1, wsFund.Columns.Count).End(xlToLeft).Column
    emailColFund = 0
    For j = 1 To lastColFund
        If LCase(Replace(wsFund.Cells(1, j).Value, "-", "")) Like "*email*" Or InStr(wsFund.Cells(1, j).Value, "邮箱") > 0 Then
            emailColFund = j
            Exit For
        End If
    Next j
    If emailColFund = 0 Then
        MsgBox "Fundraise-pages(1).csv 未识别到邮箱列，请检查表头命名", vbExclamation
        GoTo Cleanup
    End If
    
    ' 自动识别Supporters文件的邮箱列
    lastColSupp = wsSupp.Cells(1, wsSupp.Columns.Count).End(xlToLeft).Column
    emailColSupp = 0
    For j = 1 To lastColSupp
        If LCase(Replace(wsSupp.Cells(1, j).Value, "-", "")) Like "*email*" Or InStr(wsSupp.Cells(1, j).Value, "邮箱") > 0 Then
            emailColSupp = j
            Exit For
        End If
    Next j
    If emailColSupp = 0 Then
        MsgBox "Supporters(1).csv 未识别到邮箱列，请检查表头命名", vbExclamation
        GoTo Cleanup
    End If
    
    ' 字典存储Supporters数据，以统一格式的邮箱为Key，对应行号为Value，提升匹配效率
    Set dictSupp = CreateObject("Scripting.Dictionary")
    lastRowSupp = wsSupp.Cells(wsSupp.Rows.Count, emailColSupp).End(xlUp).Row
    For i = 2 To lastRowSupp
        emailVal = LCase(Trim(wsSupp.Cells(i, emailColSupp).Value))
        If emailVal <> "" And Not dictSupp.Exists(emailVal) Then
            dictSupp(emailVal) = i
        End If
    Next i
    
    ' 写入两侧表头，中间空1列分隔
    wsFund.Range(wsFund.Cells(1, 1), wsFund.Cells(1, lastColFund)).Copy wsMain.Cells(1, 1)
    wsSupp.Range(wsSupp.Cells(1, 1), wsSupp.Cells(1, lastColSupp)).Copy wsMain.Cells(1, lastColFund + 2)
    
    ' 逐行匹配邮箱写入对齐数据
    lastRowFund = wsFund.Cells(wsFund.Rows.Count, emailColFund).End(xlUp).Row
    matchRow = 2
    For i = 2 To lastRowFund
        emailVal = LCase(Trim(wsFund.Cells(i, emailColFund).Value))
        If emailVal <> "" And dictSupp.Exists(emailVal) Then
            ' 写入Fundraise当前行全量数据
            wsFund.Range(wsFund.Cells(i, 1), wsFund.Cells(i, lastColFund)).Copy wsMain.Cells(matchRow, 1)
            ' 写入匹配到的Supporters对应行全量数据
            wsSupp.Range(wsSupp.Cells(dictSupp(emailVal), 1), wsSupp.Cells(dictSupp(emailVal), lastColSupp)).Copy wsMain.Cells(matchRow, lastColFund + 2)
            matchRow = matchRow + 1
        End If
    Next i
    
    ' 自动适配列宽
    wsMain.UsedRange.EntireColumn.AutoFit
    MsgBox "合并完成，共匹配有效记录 " & matchRow - 2 & " 条", vbInformation

Cleanup:
    ' 关闭源文件不保存
    If Not wbFund Is Nothing Then wbFund.Close SaveChanges:=False
    If Not wbSupp Is Nothing Then wbSupp.Close SaveChanges:=False
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ' 释放对象内存
    Set dictSupp = Nothing
    Set wsFund = Nothing: Set wsSupp = Nothing: Set wsMain = Nothing
    Set wbFund = Nothing: Set wbSupp = Nothing: Set wbMain = Nothing
End Sub

使用步骤 #

• 打开作为合并结果载体的主Excel工作簿，按Alt+F11唤起VBA编辑器
• 在左侧工程资源管理器右键点击当前工作簿名称，选择插入 -> 模块，将上述代码粘贴到弹出的模块代码窗口
• 将两个CSV源文件放到和主工作簿相同的文件夹内，如需自定义路径可修改代码中csvPath变量的赋值为目标文件夹绝对路径
• 按F5运行宏即可，运行完成后会弹窗提示匹配到的有效记录总数
• 如需将结果写入指定工作表，可修改Set wsMain = wbMain.Sheets(1)中的工作表序号或表名

注意：邮箱匹配时会自动忽略大小写、首尾空格差异，避免因格式问题导致匹配失败；如果同一个邮箱在Supporters文件中存在多条重复记录，代码默认取第一条记录进行匹配。

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