如何使用VBA基于日期和主题双条件提取Outlook邮件数据

你的代码无法正确筛选符合条件的邮件，核心是以下3个错误：

• 逻辑运算符使用错误：VBA中判断多个条件同时满足需要用逻辑运算符And，你写的&是字符串拼接运算符，原代码里的判断逻辑实际是把主题和收到时间拼接成字符串，根本没有做双条件校验
• 日期匹配逻辑错误：ReceivedTime属性包含时/分/秒信息，Date函数返回的是当前日期（不带时间），直接用=判断永远只会匹配到当天0点整收到的邮件，几乎不可能命中目标。如果你要筛选昨日收到的邮件，需要先取ReceivedTime的日期部分和Date-1（昨日日期）对比
• 对象提前释放错误：你在循环内部就把oApp、oMapi设置为Nothing，第一次符合条件的邮件处理完后，后续遍历的邮件就找不到Outlook对象了，会直接报错或者终止运行

Option Explicit

Sub FinalMacro()
    Application.DisplayAlerts = False
    Dim wkb As Workbook
    Set wkb = ThisWorkbook
    
    Sheets("Sheet1").Cells.Clear
    
    ' 配置目标邮箱地址
    Const strMail As String = "emailaddress"
    
    Dim oApp As Outlook.Application
    Dim oMapi As Outlook.MAPIFolder
    Dim oItem As Object
    Dim targetDate As Date
    ' 配置要筛选的日期：昨日日期，你也可以自行修改为其他日期
    targetDate = Date - 1
    
    On Error Resume Next
    Set oApp = GetObject(, "OUTLOOK.APPLICATION")
    If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
    On Error GoTo 0
    
    Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
    
    ' 提前筛选邮件，比全量遍历效率高很多
    Dim filteredItems As Outlook.Items
    ' 筛选条件：主题为Volume data + 收到日期等于目标日期
    Dim filter As String
    filter = "[Subject] = 'Volume data' AND [ReceivedTime] >= '" & Format(targetDate, "ddddd hh:mm AMPM") & "' AND [ReceivedTime] < '" & Format(targetDate + 1, "ddddd hh:mm AMPM") & "'"
    Set filteredItems = oMapi.Items.Restrict(filter)
    
    For Each oItem In filteredItems
        Dim HTMLdoc As MSHTML.HTMLDocument
        Dim tables As MSHTML.IHTMLElementCollection
        Dim table As MSHTML.HTMLTable

        Set HTMLdoc = New MSHTML.HTMLDocument
        With HTMLdoc
            .Body.innerHTML = oItem.HTMLBody
            Set tables = .getElementsByTagName("table")
        End With

        Dim t As Long, r As Long, c As Long
        Dim eRow As Long

        For t = 0 To tables.Length - 1
            eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            For r = 0 To (tables(t).Rows.Length - 1)
                For c = 0 To (tables(t).Rows(r).Cells.Length - 1)
                    Range("A" & eRow).Offset(r, c).Value = tables(t).Rows(r).Cells(c).innerText
                Next c
            Next r
        Next t
        
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        Cells(eRow, 1) = "Date & Time of Receipt:" & " " & oItem.ReceivedTime
        Cells(eRow, 1).Interior.Color = vbRed
        Cells(eRow, 1).Font.Color = vbWhite
        Cells(eRow, 1).Columns.AutoFit

        Set HTMLdoc = Nothing
        Set tables = Nothing
    Next oItem
    
    ' 对象释放放到循环结束后执行
    Set oApp = Nothing
    Set oMapi = Nothing
    
    wkb.Save
    Application.DisplayAlerts = True
End Sub

• 替换了错误的逻辑运算符，使用And做多条件判断
• 新增了日期筛选逻辑，通过Date-1获取昨日日期，同时匹配时忽略时分秒的影响
• 调整了对象释放的位置，放到所有邮件遍历完成之后再执行
• 新增了Restrict方法提前筛选符合条件的邮件，不需要遍历收件箱所有邮件，运行效率大幅提升

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