Extract tables from Outlook emails in selected folder to Excel

[Pendrigh]

This code from http://www.mrexcel.com/forum/excel-...ge-excel-using-visual-basic-applications.html works to extract a table from an Outlook message into Excel, but only for the latest message received.

How could the code be changed so that it extracts all tables from all emails in a selected folder? (There is only one table in each email, and each table has the same number of rows and columns, if that matters).

Many thanks

Option Explicit

Sub impOutlookTable()

' point to the desired email
Const strMail As String = "yourEmailAddress@MrExcelForum.com"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem

On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
    If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0

Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)

' get html table from email object
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim oElColl As MSHTML.IHTMLElementCollection
With oHTML
    .Body.innerHTML = oMail.HTMLBody
    Set oElColl = .getElementsByTagName("table")
End With

'import in Excel
Dim x As Long, y As Long

For x = 0 To oElColl(0).Rows.Length - 1
    For y = 0 To oElColl(0).Rows(x).Cells.Length - 1
        Range("A1").Offset(x, y).Value = oElColl(0).Rows(x).Cells(y).innerText
    Next y
Next x

Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set oHTML = Nothing
Set oElColl = Nothing
End Sub

 

[John_w]

Try this. You must set references to Microsoft HTML Object Library and Microsoft Outlook X.00 Object Library in Tools -> References in the VBA editor.

Option Explicit

Public Sub Import_Tables_From_Outlook_Emails()

    Dim oApp As Outlook.Application
    Dim oMapi As Outlook.MAPIFolder
    Dim oMail As Outlook.MailItem
    Dim HTMLdoc As MSHTML.HTMLDocument
    Dim tables As MSHTML.IHTMLElementCollection
    Dim table As MSHTML.HTMLTable
    Dim x As Long, y As Long
    Dim destCell As Range
    
    With ActiveSheet
        Set destCell = .Cells(Rows.Count, "A").End(xlUp)
    End With
   
    On Error Resume Next
    Set oApp = GetObject(, "OUTLOOK.APPLICATION")
    If oApp Is Nothing Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
    On Error GoTo 0
    
    Set oMapi = oApp.GetNamespace("MAPI").PickFolder
    
    If Not oMapi Is Nothing Then
    
        For Each oMail In oMapi.Items
    
            'Get HTML tables from email object
            
            Set HTMLdoc = New MSHTML.HTMLDocument
            With HTMLdoc
                .Body.innerHTML = oMail.HTMLBody
                Set tables = .getElementsByTagName("table")
            End With
        
            'Import each table into Excel
            
            For Each table In tables
                For x = 0 To table.Rows.Length - 1
                    For y = 0 To table.Rows(x).Cells.Length - 1
                        destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
                    Next y
                Next x
                Set destCell = destCell.Offset(x)
            Next
        
        Next
            
        MsgBox "Finished"
        
    End If
    
    Set oApp = Nothing
    Set oMapi = Nothing
    Set oMail = Nothing
    Set HTMLdoc = Nothing
    Set tables = Nothing
    
End Sub

 

[Pendrigh]

That's excellent, John_w. Many thanks.

 

[smithy1111]

Hi,

Can anyone please advise on modifying John_w's excellent code above so that each table extracted has the email subject and email date included in separate cells next to each table?

Thank you

 

[John_w]

each table extracted has the email subject and email date included in separate cells next to each table?

Insert the new line as follows:

                destCell.Offset(, y).Resize(, 2).Value = Array(oMail.Subject, Format(oMail.ReceivedTime, "Short date"))   '<-------- new line
                Set destCell = destCell.Offset(x)  '<----- existing line

Please start a new thread if you need more help.