请求优化VBA脚本：从指定邮件提取地址变更信息至Excel表格

嘿，我明白你现在的需求：要从4种特定格式的邮件文件名里扒出新旧地址，再批量写到Excel表格里。咱们先从最核心的文件名解析逻辑入手，再把文件遍历和Excel操作的环节串起来，一步步搞定这个需求。

一、先搞定单个文件名的地址解析 #

你给出的示例文件名是 "Address Change Circulation - 14 to 12 Queen S..."，这类格式的核心是用 "to" 分隔新旧地址。我先写一个通用解析函数，你后续可以根据另外3种格式补充调整：

Function ParseAddressFromFileName(fileName As String) As Variant
    Dim result(1 To 2) As String ' 1=旧地址, 2=新地址
    Dim tempStr As String
    
    ' 先砍掉文件名里的固定前缀（比如示例里的"Address Change Circulation - "）
    tempStr = Replace(fileName, "Address Change Circulation - ", "")
    
    ' 用"to"分割新旧地址（如果你的其他格式里有大小写不同的"To"，可以加LCase统一处理）
    Dim splitArr As Variant
    splitArr = Split(tempStr, " to ")
    
    If UBound(splitArr) = 1 Then
        result(1) = Trim(splitArr(0))
        ' 去掉新地址末尾的省略号或多余字符（比如示例里的"..."）
        result(2) = Trim(Left(splitArr(1), InStr(splitArr(1), "...") - 1))
    Else
        ' 格式不匹配时返回空值，后续可以标记异常
        result(1) = ""
        result(2) = ""
    End If
    
    ParseAddressFromFileName = result
End Function

二、批量遍历文件夹+写入Excel #

接下来写一个主过程，让它自动遍历指定文件夹里的邮件文件，调用上面的解析函数，把结果写到Excel里：

Sub BatchExtractAddressesToExcel()
    Dim folderPath As String
    Dim fileName As String
    Dim ws As Worksheet
    Dim rowNum As Integer
    Dim addressArr As Variant
    
    ' 指定要写入的工作表（这里用当前工作簿的Sheet1，你可以改成自己需要的表名）
    Set ws = ThisWorkbook.Sheets("Sheet1")
    rowNum = 2 ' 第1行留着写表头：A1=旧地址, B1=新地址, C1=原文件名
    
    ' 弹出窗口让你选目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择存放地址变更邮件的文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "没选文件夹哦，程序退出啦"
            Exit Sub
        End If
    End With
    
    ' 遍历文件夹里的.msg格式邮件（如果你的邮件是其他格式，改后缀就行，比如.eml）
    fileName = Dir(folderPath & "*.msg")
    Do While fileName <> ""
        ' 解析当前文件名
        addressArr = ParseAddressFromFileName(fileName)
        
        ' 把结果写入Excel
        ws.Cells(rowNum, 1).Value = addressArr(1)
        ws.Cells(rowNum, 2).Value = addressArr(2)
        ws.Cells(rowNum, 3).Value = fileName ' 保留原文件名方便核对
        
        ' 解析失败的行标红提醒
        If addressArr(1) = "" Or addressArr(2) = "" Then
            ws.Rows(rowNum).Interior.Color = RGB(255, 200, 200)
        End If
        
        rowNum = rowNum + 1
        fileName = Dir()
    Loop
    
    MsgBox "搞定啦！一共处理了 " & rowNum - 2 & " 个文件"
End Sub

三、适配另外3种文件名格式的小技巧 #

因为你说有4种格式，上面的函数只适配了一种。你可以把另外3种格式的示例告诉我，比如类似 "Addr Change: Old 10 Main St -> New 20 Oak Ave" 或者 "Update Address: From 5 Pine Rd To 7 Maple Ln" 这类，我可以帮你补充解析逻辑。

简单来说，就是在ParseAddressFromFileName函数里加分支判断：

• 如果文件名包含 "->"，就用Split(tempStr, " -> ")分割
• 如果包含 "From" 和 "To"，就先拆出From后面的内容，再用To分割

四、使用前的小提醒 #

1. 打开Excel按Alt+F11进入VBA编辑器，把代码粘贴到新建的模块里；
2. 先在Sheet1的A1、B1、C1分别输入旧地址、新地址、原文件名当表头；
3. 先拿几个测试文件跑一遍，没问题再批量处理；
4. 如果你的邮件不是.msg格式，记得修改代码里的Dir(folderPath & "*.msg")后缀。

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