求Excel Macro：提取Outlook邮件带R1-R6标记括号内数据至对应行

前置准备 #

• 打开Excel，点击开发工具选项卡 → Visual Basic（或按Alt+F11快速打开VBA编辑器）
• 点击工具 → 引用，勾选Microsoft Outlook XX.X Object Library（XX.X对应你的Outlook版本）和Microsoft VBScript Regular Expressions 5.5，点击确定。

完整VBA代码 #

Sub ExtractOutlookData()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim regEx As New RegExp
    Dim matches As MatchCollection
    Dim match As match
    Dim rowNum As Integer
    Dim targetSheet As Worksheet
    
    ' 指定数据写入的目标工作表，可修改为具体表名如Sheets("Sheet1")
    Set targetSheet = ActiveSheet
    ' 清空工作表现有数据（可选，按需保留）
    targetSheet.Cells.ClearContents
    
    ' 初始化Outlook对象
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    
    ' 设置要扫描的Outlook文件夹路径，示例为收件箱下的"待处理邮件"子文件夹
    ' 如需扫描根文件夹（如收件箱），直接改为Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
    On Error Resume Next
    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox).Folders("待处理邮件")
    On Error GoTo 0
    
    ' 检查指定文件夹是否存在
    If olFolder Is Nothing Then
        MsgBox "指定的Outlook文件夹不存在，请检查路径设置！", vbExclamation
        Exit Sub
    End If
    
    ' 配置正则规则：匹配R1-R6格式的括号内容，例如R1(XXX)、R2(YYYY)
    With regEx
        .Global = True
        .IgnoreCase = False
        .Pattern = "R([1-6])\(([^)]+)\)"
    End With
    
    ' 遍历文件夹内所有邮件
    For Each olMail In olFolder.Items
        ' 仅处理标准邮件项
        If olMail.Class = olMail Then
            ' 合并邮件主题、正文（签名已包含在Body属性中）
            Dim fullContent As String
            fullContent = olMail.Subject & vbCrLf & olMail.Body
            
            ' 执行正则匹配
            Set matches = regEx.Execute(fullContent)
            
            ' 将匹配结果写入对应行
            For Each match In matches
                rowNum = CInt(match.SubMatches(0)) ' 获取R后的数字作为行号
                ' 默认写入对应行的A列，可修改数字1为目标列号（如2对应B列）
                targetSheet.Cells(rowNum, 1).Value = match.SubMatches(1)
                ' 若需保留同一R标记的所有匹配项，可替换为下方追加逻辑：
                ' targetSheet.Cells(rowNum, targetSheet.Columns(rowNum).End(xlToLeft).Column + 1).Value = match.SubMatches(1)
            Next match
        End If
    Next olMail
    
    ' 释放占用的对象资源
    Set olMail = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
    Set regEx = Nothing
    
    MsgBox "数据提取完成！", vbInformation
End Sub

使用说明 #

1. 修改文件夹路径：找到代码中Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox).Folders("待处理邮件")这一行，将"待处理邮件"替换为你实际要扫描的文件夹名称。
2. 调整写入位置：代码默认将提取内容写入对应行的A列，如需更改列，修改targetSheet.Cells(rowNum, 1)中的数字1为目标列号（如3对应C列）。
3. 运行宏：回到Excel界面，点击开发工具 → 宏，选择ExtractOutlookData后点击执行即可。

注意事项 #

• 运行前确保Outlook处于打开状态，避免权限报错。
• 若文件夹内邮件数量较多，运行时间可能较长，请耐心等待。
• 若同一R标记在单封邮件中多次出现，当前代码会覆盖之前的内容；如需保留所有匹配结果，可启用代码中注释的追加行。

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