求依据Excel映射表用VBA批量替换XML中邮箱的宏代码

实现步骤与VBA代码 #

前置准备 #

• 确保c:\mydocument路径下的usermapping.xlsx文件A、B列邮箱数据从第2行开始（第1行可留作表头，如A1填「旧邮箱」、B1填「新邮箱」），有效数据行无空值
• 运行代码前请备份所有XML文件，避免误操作导致数据丢失

使用方法 #

1. 打开usermapping.xlsx文件，按下Alt + F11打开VBA编辑器
2. 右键点击当前工作簿 → 插入 → 模块，将以下代码粘贴到模块中
3. 按下F5运行即可

Sub BatchReplaceXmlEmail()
    Dim targetFolder As String
    Dim xmlFilePath As String
    Dim fso As Object
    Dim xmlContent As String
    Dim mappingDict As Object
    Dim lastRow As Long
    Dim i As Long
    Dim oldEmail As String
    Dim newEmail As String
    
    ' 配置目标文件夹路径
    targetFolder = "c:\mydocument\"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set mappingDict = CreateObject("Scripting.Dictionary")
    
    ' 读取Excel中的邮箱映射关系
    lastRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRow
        oldEmail = Trim(ThisWorkbook.Sheets(1).Cells(i, "A").Value)
        newEmail = Trim(ThisWorkbook.Sheets(1).Cells(i, "B").Value)
        If oldEmail <> "" And newEmail <> "" Then
            mappingDict(oldEmail) = newEmail
        End If
    Next i
    
    ' 遍历文件夹下所有XML文件
    xmlFilePath = Dir(targetFolder & "*.xml")
    Do While xmlFilePath <> ""
        ' 读取XML文件内容，最后参数-1为UTF-8编码，乱码可改为0使用ANSI编码
        xmlContent = fso.OpenTextFile(targetFolder & xmlFilePath, 1, False, -1).ReadAll
        
        ' 批量替换所有匹配的邮箱
        For Each oldEmail In mappingDict.Keys
            xmlContent = Replace(xmlContent, oldEmail, mappingDict(oldEmail))
        Next oldEmail
        
        ' 写回修改后的内容
        fso.CreateTextFile(targetFolder & xmlFilePath, 2, True).Write xmlContent
        
        ' 处理下一个文件
        xmlFilePath = Dir
    Loop
    
    ' 释放对象
    Set mappingDict = Nothing
    Set fso = Nothing
    MsgBox "批量替换完成！"
End Sub

调整说明 #

• 若映射表没有表头，可将循环起始值i = 2修改为i = 1
• 若替换后XML出现乱码，可根据文件编码调整OpenTextFile的最后一个参数

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