VBA提取Outlook邮件数据时如何跳过无正文数据表的邮件

• 现有VBA脚本用于回溯45天邮件，从Outlook指定的NewHires子收件箱中提取新入职/离职类邮件的正文表格内容，替代手动逐封打开邮件复制数据的操作。
• 部分邮件正文无对应数据表，仅显示no records found文本，代表统计周期内无入职/离职人员变动。

遍历处理无数据表的邮件时，会出现邮件接收时间与提取数据匹配错位的问题：

例：6月2日、3日、4日收到带数据表的邮件，6月5日收到无数据表邮件，6月6日收到带数据表邮件。现有逻辑不会跳过6月5日无表邮件的时间属性，反而会错误将6月6日邮件的表格数据关联到6月5日条目下，最终输出结果为6/2、6/3、6/4、6/5（实际加载6/6的表格数据），而非正确跳过6/5条目，展示6/2、6/3、6/4、6/6的对应匹配数据。

Sub Extractor()

Range("A2:H30000").Clear
Dim OLApp As Outlook.Application
Set OLApp = New Outlook.Application

Dim ONS As Outlook.Namespace

Set ONS = OLApp.GetNamespace("MAPI")
Dim MYFOLDER As Outlook.Folder
 
Set MYFOLDER = ONS.Folders("fakeemail@fakeemail.com").Folders("Inbox")
Set MYFOLDER = MYFOLDER.Folders("NewHires")

Dim OLMAIL As Outlook.MailItem
Set OLMAIL = OLApp.CreateItem(olMailItem)

Set myItems = MYFOLDER.Items
myItems.Sort "ReceivedTime", True
 
For Each OLMAIL In myItems
    Dim daysBack As Date
    Dim dateOfEmail As Date
    daysBack = VBA.Now - 45
    dateOfEmail = OLMAIL.ReceivedTime
    If dateOfEmail < daysBack Then Exit For

    Dim oHTML As MSHTML.HTMLDocument
    Set oHTML = New MSHTML.HTMLDocument

    Dim oElColl As MSHTML.IHTMLElementCollection
    With oHTML
        .Body.innerHTML = OLMAIL.HTMLBody
        Set oElColl = .getElementsByTagName("table")
    End With
 
    Dim t As Long, r As Long, c As Long
    Dim eRow As Long

    For t = 0 To oElColl.Length - 1
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        For r = 0 To (oElColl(t).Rows.Length - 1)
            For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                Range("A" & eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
            Next c
        Next r
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    
    Next t

    Cells(eRow, 1) = "Sender's Name:" & " " & OLMAIL.Sender
    Cells(eRow, 1).Interior.Color = vbRed
    Cells(eRow, 1).Font.Color = vbWhite
    Cells(eRow, 2) = OLMAIL.ReceivedTime
    Cells(eRow, 2).Interior.Color = vbBlue
    Cells(eRow, 2).Font.Color = vbWhite
    Range(Cells(eRow, 1), Cells(eRow, 2)).Columns.AutoFit
Next OLMAIL

Range("A2").Select

Set OLApp = Nothing
Set OLMAIL = Nothing
Set oHTML = Nothing
Set oElColl = Nothing

ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
 
End Sub

代码未对无表格的邮件做跳过判断：当邮件正文不存在table元素时，oElColl.Length值为0，遍历表格的For t = 0 To oElColl.Length - 1循环不会执行，变量eRow会保留上一封邮件处理时的旧行号，后续写入发件人、接收时间的逻辑仍会执行，直接把当前无表邮件的元数据写到上一封邮件的表格数据之后，造成后续所有邮件的数据和时间错位。

在获取table元素集合后，增加长度判断，若不存在表格则直接跳过当前邮件，不执行后续元数据写入逻辑；同时增加对象释放逻辑，避免变量残留旧值造成错位。

修改后完整代码 #

Sub Extractor()
    Range("A2:H30000").Clear
    Dim OLApp As Outlook.Application
    Set OLApp = New Outlook.Application

    Dim ONS As Outlook.Namespace
    Set ONS = OLApp.GetNamespace("MAPI")
    Dim MYFOLDER As Outlook.Folder
 
    Set MYFOLDER = ONS.Folders("fakeemail@fakeemail.com").Folders("Inbox")
    Set MYFOLDER = MYFOLDER.Folders("NewHires")

    Dim OLMAIL As Outlook.MailItem
    Set OLMAIL = OLApp.CreateItem(olMailItem)

    Set myItems = MYFOLDER.Items
    myItems.Sort "ReceivedTime", True
 
    For Each OLMAIL In myItems
        Dim daysBack As Date
        Dim dateOfEmail As Date
        daysBack = VBA.Now - 45
        dateOfEmail = OLMAIL.ReceivedTime
        If dateOfEmail < daysBack Then Exit For

        Dim oHTML As MSHTML.HTMLDocument
        Set oHTML = New MSHTML.HTMLDocument

        Dim oElColl As MSHTML.IHTMLElementCollection
        With oHTML
            .Body.innerHTML = OLMAIL.HTMLBody
            Set oElColl = .getElementsByTagName("table")
        End With
        
        ' 无表格直接跳过当前邮件
        If oElColl.Length = 0 Then GoTo NextMail
 
        Dim t As Long, r As Long, c As Long
        Dim eRow As Long

        For t = 0 To oElColl.Length - 1
            eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            For r = 0 To (oElColl(t).Rows.Length - 1)
                For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                    Range("A" & eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
                Next c
            Next r
            eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        Next t

        Cells(eRow, 1) = "Sender's Name:" & " " & OLMAIL.Sender
        Cells(eRow, 1).Interior.Color = vbRed
        Cells(eRow, 1).Font.Color = vbWhite
        Cells(eRow, 2) = OLMAIL.ReceivedTime
        Cells(eRow, 2).Interior.Color = vbBlue
        Cells(eRow, 2).Font.Color = vbWhite
        Range(Cells(eRow, 1), Cells(eRow, 2)).Columns.AutoFit
        
NextMail:
        ' 释放当前邮件对象引用，避免残留
        Set OLMAIL = Nothing
    Next OLMAIL

    Range("A2").Select

    Set OLApp = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing

    ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
End Sub

• 新增If oElColl.Length = 0 Then GoTo NextMail判断，正文无表格的邮件直接跳过，不写入任何元数据
• 增加循环跳转标签NextMail，统一处理无表邮件的跳过逻辑
• 每轮循环结束释放当前OLMAIL对象引用，避免对象残留造成的异常

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