如何用VBA将Outlook全邮箱特定主题邮件表格数据导入Excel并保留旧数据

以下是满足需求的修改版代码，解决了不覆盖原有数据和遍历所有邮箱文件夹的问题：

Sub GetAllEmailsWithTables()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim rootFolder As Outlook.MAPIFolder
    Dim targetSheet As Worksheet
    Dim nextRow As Long
    
    '初始化Outlook对象
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set rootFolder = olNs.GetDefaultFolder(olFolderInbox).Parent '获取邮箱根目录，包含所有文件夹
    Set targetSheet = ThisWorkbook.Sheets("Sheet1")
    
    '获取现有数据的最后一行，新数据从下一行开始
    nextRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
    
    '递归遍历所有文件夹
    Call ProcessFolder(rootFolder, targetSheet, nextRow)
    
    '清理空行（仅处理新导入的部分）
    Dim lastRow As Long
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
    For i = lastRow To nextRow Step -1
        If Trim(targetSheet.Cells(i, "A").Value) = "" Then
            targetSheet.Rows(i).Delete
        End If
    Next i

    '释放对象
    Set targetSheet = Nothing
    Set rootFolder = Nothing
    Set olNs = Nothing
    Set olApp = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "数据导入完成！"
End Sub

'递归处理所有子文件夹的函数
Private Sub ProcessFolder(ByVal olFldr As Outlook.MAPIFolder, ByVal ws As Worksheet, ByRef startRow As Long)
    Dim olItms As Outlook.Items
    Dim olMail As Outlook.MailItem
    Dim olHTML As MSHTML.HTMLDocument
    Dim olEleColl As MSHTML.IHTMLElementCollection
    Dim t As MSHTML.HTMLTable
    Dim i As Long, j As Long
    Dim currentRow As Long
    
    Set olItms = olFldr.Items
    olItms.Sort "ReceivedTime", olDescending '按收件时间排序，可按需调整
    
    '遍历当前文件夹的邮件
    For Each olMail In olItms
        '仅处理邮件项，跳过会议邀请等其他类型
        If olMail.Class = olMail Then
            '匹配指定主题，忽略大小写
            If InStr(1, olMail.Subject, "Memo required", vbTextCompare) > 0 Then
                Set olHTML = New MSHTML.HTMLDocument
                olHTML.body.innerHTML = olMail.HTMLBody
                Set olEleColl = olHTML.getElementsByTagName("table")
                
                currentRow = startRow
                '遍历邮件中的所有表格
                For Each t In olEleColl
                    '导入表格数据
                    For i = 0 To t.Rows.Length - 1
                        For j = 0 To t.Rows(i).Cells.Length - 1
                            On Error Resume Next
                            ws.Cells(currentRow + i, j + 1).Value = t.Rows(i).Cells(j).innerText
                            On Error GoTo 0
                        Next j
                    Next i
                    '更新起始行，表格间空一行分隔
                    startRow = currentRow + t.Rows.Length + 1
                Next t
            End If
        End If
    Next olMail
    
    '递归处理子文件夹
    Dim subFolder As Outlook.MAPIFolder
    For Each subFolder In olFldr.Folders
        Call ProcessFolder(subFolder, ws, startRow)
    Next subFolder
    
    '释放对象
    Set subFolder = Nothing
    Set olEleColl = Nothing
    Set olHTML = Nothing
    Set olMail = Nothing
    Set olItms = Nothing
End Sub

关键修改说明 #

• 不覆盖原有数据：

  • 新增nextRow变量，通过Cells(Rows.Count, "A").End(xlUp).Row + 1获取现有数据的下一行作为新数据的起始位置
  • 导入时直接从nextRow开始写入，完全保留原有内容

• 遍历全邮箱：

  • 新增递归函数ProcessFolder，自动遍历指定文件夹下的所有子文件夹
  • 从邮箱根目录（olNs.GetDefaultFolder(olFolderInbox).Parent）开始遍历，覆盖收件箱、已发送邮件、草稿等所有文件夹

• 其他优化：

  • 增加olMail.Class = olMail判断，仅处理邮件类型，跳过会议邀请、任务等非邮件项
  • 使用vbTextCompare进行主题匹配，忽略大小写
  • 空行清理逻辑仅针对新导入的数据，避免误删原有内容

注意：需要确保Excel中已引用Microsoft Outlook xx.x Object Library和Microsoft HTML Object Library（VBA编辑器 -> 工具 -> 引用）

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