如何使用VBA自动将Outlook中的表格数据与具有特定主题的邮件传输到Excel？

Question

我一直在研究这个问题，自动将特定主题的邮件中的数据从 Outlook 传输到 Excel，任何人都可以做到这一点，以便代码在将信息粘贴到 Excel 时，不会删除旧数据并检查我的整个邮箱包括旧邮件和新邮件。这是我目前拥有的代码。

Sub GetFromInbox()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i, j, eRow As Long
Dim olMail1 As Outlook.MailItem
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim t
Dim posicao As String

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items

olItms.Sort "Subject"

i = 1
xRow = 1
For Each olMail In olItms
    If InStr(1, olMail.Subject, "Memo required") > 0 Then
'    If InStr(1, olMail.Subject, "Supplier2 Pipeline Schedule - 26 Mar 2021") > 0 Then
        With olHTML
            .body.innerHTML = olMail.HTMLBody
            Set olEleColl = .getElementsByTagName("table")
        End With
        
        With ThisWorkbook.Sheets("Sheet1")
            'which row to start
            eRow = 1
            posicao = "A" & eRow
            For Each t In olEleColl
                For i = 0 To t.Rows.Length - 1
                    For j = 0 To t.Rows(i).Cells.Length - 1
                        'ignore any problems with merged cells etc
                        On Error Resume Next
                        .Range(posicao).Offset(i, j).Value = t.Rows(i).Cells(j).innerText
                        On Error GoTo 0
                    Next j
                Next i
                'define from which row the next table will be written
                eRow = eRow + t.Rows.Length + 1
                posicao = "A" & eRow
            Next t
        End With
    End If
Next olMail

Last = Cells(Rows.Count, "A").End(xlUp).Row
For i = Last To 1 Step -1
    If (Cells(i, "A").Value) = " " Then
        Cells(i, "A").EntireRow.Delete
    End If
Next i


Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Answer 1

要从先前复制的表格之后开始，并跳过每个表格中的第一列：

       '...
       '...
       Dim cPos As Range 'start cell for copied table
       
       With ThisWorkbook.Sheets("Sheet1")
           Set cPos = .Cells(.Rows.Count,"A").End(xlUp).Offset(1) 'next empty cell in ColA
       End With
       
       For Each t In olEleColl
            For i = 0 To t.Rows.Length - 1
                For j = 1 To t.Rows(i).Cells.Length - 1  'start at second cell
                   'ignore any problems with merged cells etc
                   On Error Resume Next
                   cPos.Offset(i, j-1).Value = t.Rows(i).Cells(j).innerText
                   On Error GoTo 0
                Next j
            Next i                
            eRow = eRow + t.Rows.Length + 1 'increment for next table
        Next t
        '...
        '...