Outlook邮件特定数据提取至Excel表格的宏代码问题求助

问题1：编译错误"End if without block if" #

你的代码里多了一行End If，但前面没有对应的If判断语句——VBA要求If和End If必须成对出现。直接删掉循环里的End If即可，修改后的循环部分代码：

For Each OutlookMail In Folder.Items
        Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
        Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body

        i = i + 1
Next OutlookMail

问题2：扫描邮件自动签名内容 #

Outlook邮件的Body属性已经包含了自动签名内容，你当前代码里的OutlookMail.Body已经能获取到带签名的完整正文，不需要额外处理。

问题3：提取R1-R6标记的括号内数据并对应Excel行 #

可以写一个自定义函数提取指定标记后的括号内容，再在循环里调用函数把数据写入对应行。以下是完整修改后的代码：

Sub GetFromOutlook()
    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Namespace
    Dim Folder As MAPIFolder
    Dim OutlookMail As Variant
    Dim i As Integer
    Dim fullContent As String
    Dim rNum As Integer
    
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("NoV")

    i = 1
    
    For Each OutlookMail In Folder.Items
        ' 合并主题+正文，确保能扫描到所有位置的标记
        fullContent = OutlookMail.Subject & vbCrLf & OutlookMail.Body
        
        ' 提取R1-R6数据并写入对应行
        For rNum = 1 To 6
            Cells(rNum, 1).Value = ExtractTagData(fullContent, "R" & rNum)
        Next rNum
        
        ' 保留原有的邮件基础信息写入逻辑
        Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
        Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body

        i = i + 1
    Next OutlookMail

    Set Folder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
End Sub

' 自定义函数：提取指定标记后括号内的内容
Function ExtractTagData(content As String, tag As String) As String
    Dim tagPos As Integer
    Dim openBracketPos As Integer
    Dim closeBracketPos As Integer
    
    ' 定位标记位置
    tagPos = InStr(1, content, tag, vbTextCompare)
    If tagPos = 0 Then
        ExtractTagData = ""
        Exit Function
    End If
    
    ' 定位标记后的第一个左括号
    openBracketPos = InStr(tagPos + Len(tag), content, "(")
    If openBracketPos = 0 Then
        ExtractTagData = ""
        Exit Function
    End If
    
    ' 定位对应右括号
    closeBracketPos = InStr(openBracketPos, content, ")")
    If closeBracketPos = 0 Then
        ExtractTagData = ""
        Exit Function
    End If
    
    ' 提取括号内文本
    ExtractTagData = Mid(content, openBracketPos + 1, closeBracketPos - openBracketPos - 1)
End Function

代码说明： #

• ExtractTagData函数：用InStr定位标记和括号位置，再用Mid提取目标文本，支持不区分大小写匹配。
• 主逻辑里合并主题和正文，确保不会漏掉主题中的标记。
• 通过循环rNum=1到6，将R1-R6对应的数据分别写入Excel第1到第6行第1列（如需调整列，修改Cells(rNum, 1)中的列号即可）。

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