Excel VBA - 从 Outlook 中获取 Table 并粘贴到 Excel

Question

我正在尝试在@RyanL 的 Excel 上使用此代码从电子邮件中提取table。但是，我没有编码经验，所以我想在以下方面得到一些帮助。

我每周都会收到来自两个来源的具有特定主题 ("Source" & # & "Pipeline Schedule -" & "Date()") 但彼此不同的电子邮件。 Source1 发送正文 table 并以 PDF 格式发送 Source2 仅在正文发送一个或两个 table。

使用前面提到的 post 的答案，我能够复制整个正文，但不幸的是它把它粘贴在一个单元格中（除了那里的建议之外，不知道为什么）。但是，就我而言，我只需要 tables.

见下方代码

Sub GetFromInbox()
    
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 As Long
Dim xTable As Word.Table
Dim xDoc As Word.document
Dim xRow As Integer

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

olItms.Sort "Subject"

i = 1
On Error Resume Next

xRow = 1
For Each olMail In olItms
    If InStr(1, olMail.Subject, "Supplier 2 Pipeline Schedule - 26 Mar 2021") > 0 Then
    Set xDoc = olMail.GetInspector.WordEditor
    For i = 1 To xDoc.Tables.Count
        Set xTable = xDoc.Tables(i)
        xTable.Range.Copy
        ThisWorkbook.Sheets("Sheet2").Paste
        xRow = xRow + xTable.Rows.Count + 1
        ThisWorkbook.Sheets("Sheet2").Range("A" & CStr(xRow)).Select
    Next
    End If
Next olMail
    
    Set olFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
    
    End Sub

也许答案在某处 posted，但由于我的知识有限，我可能无法找到它。有什么建议吗？

编辑：因此，我设法合并了一些代码并从 Outlook 导入 tables（请参阅更新的代码）。但是，在其中一个供应商上，它还会从电子邮件签名中复制图像。我们能避免吗？第二个问题是 tables 没有粘贴在第一行，所以对我来说很难自动操作数据。有任何想法吗？第 3 期，此电子邮件中的某些部分与“草稿”计划有对应关系。一旦到达当前通信的末尾，是否可以以某种方式停止阅读电子邮件正文？

干杯

Answer 1

所以，我已经设法让它工作，使用部分@Kobayashi 代码。见下文以供参考。

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, "Supplier1 Pipeline Schedule - 26 Mar 2021") > 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

欢迎提出任何优化建议。

Excel VBA - 从 Outlook 中获取 Table 并粘贴到 Excel

Excel VBA - Get Table from Outlook and Paste to Excel

excel

outlook

vba