Excel VBA - Get Table from Outlook and Paste to Excel

Question

I'm trying to use this code on Excel from an old post by @RyanL to extract a table from an email. However, I'm not experience with coding so, I would like some help with the following.

Weekly, I'm receiving emails from two sources with a specific subject ("Source" & # & "Pipeline Schedule -" & "Date()") but different to each other. Source1 send the table on its body and in a PDF format where Source2 send either one or two table only on its body.

Using the answer from the aforementioned post, I'm able to copy the whole body but unfortunately it paste it in one cell (can't figure out why, beside the suggestion there). However, in my case I only need the tables.

See the code below

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

Maybe the answer is posted somewhere, but due to my limited knowledge I probably can't locate it. Any suggestion?

EDIT: So, I managed to combine some codes and import tables from Outlook (see updated code). However, on one of the Supplier, it also copy the images from the email signature. Can we avoid that? 2nd issue is that the tables are not pasted on the 1st Row so, for me with hard to manipulate the data automatically. Any ideas? 3rd issue, some of this email have a trail of correspondence with "draft" plans. Can somehow stop reading the email body once it reach the end of the current correspond?

Cheers

Something like [this](https://www.extendoffice.com/documents/outlook/5225-export-outlook-email-body-table-to-excel.html) maybe? Or maybe [this](https://stackoverflow.com/questions/50377762/automatically-export-html-table-from-outlook-to-excel-w-vba)? — urdearboy, Mar 24 '21 at 22:06
Thank you both @urdearboy and sideshowbarker. Correctly if I'm wrong, but my understanding is that those links are code for Outlook vba. I'm looking for one to apply to Excel as it would be easier to share an excel file with my colleagues rather applying a vba across multiple outlook accounts? — Geo Koro, Mar 25 '21 at 02:08

score 1 · Accepted Answer · answered Mar 27 '21 at 09:19

So, I've managed to make it work, using parts of @Kobayashi code. See below for reference.

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

Any suggestion for optimisation is welcome.

Excel VBA - Get Table from Outlook and Paste to Excel

1 Answers1