如何通过VBA获取最新Outlook邮件并追加至现有文件，替代全量遍历邮件的方式

Got it, let's revamp your VBA macro to solve the slow full-traversal issue and make it append data instead of overwriting everything. Here's the optimized code along with clear explanations of the key changes:

Option Explicit
Sub FinalMacro()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False ' Speed up macro by disabling screen updates
    
    Dim wkb As Workbook
    Set wkb = ThisWorkbook
    Dim ws As Worksheet
    Set ws = wkb.Sheets("Sheet1") ' Use a worksheet variable for cleaner code
    
    ' Outlook objects
    Dim oApp As Outlook.Application
    Dim oMapi As Outlook.MAPIFolder
    Dim filteredItems As Outlook.Items
    Dim oItem As Object
    
    ' Define date range for yesterday's emails
    Dim startDate As Date, endDate As Date
    startDate = Date - 1 ' Yesterday at 00:00
    endDate = Date ' Today at 00:00 (covers all emails up to midnight yesterday)
    
    ' Initialize Outlook instance
    On Error Resume Next
    Set oApp = GetObject(, "OUTLOOK.APPLICATION")
    If oApp Is Nothing Then
        Set oApp = CreateObject("OUTLOOK.APPLICATION")
    End If
    On Error GoTo 0
    
    ' Point to your target subfolder
    Const strMail As String = "emailaddress@outlook.com"
    Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox").Folders("Other mails")
    
    ' Filter items to only yesterday's emails with subject "Volume data"
    Dim filterStr As String
    filterStr = "[ReceivedTime] >= '" & Format(startDate, "ddddd hh:mm AMPM") & "' AND " & _
                "[ReceivedTime] < '" & Format(endDate, "ddddd hh:mm AMPM") & "' AND " & _
                "[Subject] = 'Volume data'"
    Set filteredItems = oMapi.Items.Restrict(filterStr)
    filteredItems.Sort "[ReceivedTime]", olDescending ' Optional: Sort newest first
    
    ' Process each filtered email
    Dim HTMLdoc As MSHTML.HTMLDocument
    Dim tables As MSHTML.IHTMLElementCollection
    Dim table As MSHTML.HTMLTable
    Dim t As Long, r As Long, c As Long
    Dim eRow As Long
    
    For Each oItem In filteredItems
        If TypeName(oItem) = "MailItem" Then ' Skip non-mail items (e.g., meeting requests)
            Set HTMLdoc = New MSHTML.HTMLDocument
            HTMLdoc.Body.innerHTML = oItem.HTMLBody
            Set tables = HTMLdoc.getElementsByTagName("table")
            
            ' Write table data to the next empty row
            For t = 0 To tables.Length - 1
                eRow = ws.Cells(ws.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)
                        ws.Cells(eRow + r, c + 1).Value = tables(t).Rows(r).Cells(c).innerText
                    Next c
                Next r
            Next t
            
            ' Add receipt timestamp below the table
            eRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            With ws.Cells(eRow, 1)
                .Value = "Date & Time of Receipt:" & " " & oItem.ReceivedTime
                .Interior.Color = vbRed
                .Font.Color = vbWhite
            End With
            
            ' Cleanup HTML objects for this email
            Set HTMLdoc = Nothing
            Set tables = Nothing
        End If
    Next oItem
    
    ' Auto-fit columns for readability
    ws.Columns.AutoFit
    
    ' Save the workbook to preserve appended data
    wkb.Save
    
    ' Cleanup all objects to free memory
    Set oItem = Nothing
    Set filteredItems = Nothing
    Set oMapi = Nothing
    Set oApp = Nothing
    Set ws = Nothing
    Set wkb = Nothing
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Data fetched and appended successfully!", vbInformation
End Sub

Key Improvements & Explanations #

• Fast Filtering Instead of Full Traversal:
  We use Outlook's Restrict method to directly fetch only emails that match two criteria: received yesterday and subject equals "Volume data". This is way faster than looping through thousands of emails because it filters items at the source (Outlook/Exchange) instead of loading every email into memory.

• Append Data, Don't Overwrite:
  Removed the Sheets("Sheet1").Cells.Clear line so your existing data stays intact. The eRow variable always finds the last used row in Column A and starts writing new data below it, ensuring old records aren't lost.

• Better Performance:
  Disabled ScreenUpdating during the macro to prevent Excel from redrawing the sheet every time data is added—this cuts down on runtime significantly. We also use worksheet variables (ws) to reduce redundant calls to the worksheet object.

• Robust Error & Object Handling:
  Added a check to ensure we only process MailItem objects (skipping things like meeting requests that might be in the folder). Also fixed the object cleanup logic (your original code was setting oApp = Nothing inside the loop, which would break subsequent iterations).

• Optional Sorting:
  We sorted the filtered items by ReceivedTime in descending order so you process the newest emails first—you can remove this line if order doesn't matter.

Quick Setup Checks #

1. Enable MSHTML Reference: In the VBA editor, go to Tools > References and check Microsoft HTML Object Library (required to parse the email's HTML body).
2. Adjust Date Range: If you need to fetch emails from the last 24 hours instead of the previous calendar day, replace startDate = Date -1 with startDate = Now() - 24.
3. Verify Folder Path: Double-check that the folder path (Folders("inbox").Folders("Other mails")) matches your actual Outlook folder structure.

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