Extract Table from Outlook Message to Excel using VBA

[SeanDamnit]

Hey Kids,

Apologies if this is more Outlook related than Excel, but this forum has been my best resource for VBA help.

What I'd like to do is run a macro every time certain e-mails come in that would extract some text and a table in to an excel document. Opening the excel document and adding specific parts of the body text is fairly straight forward, but getting the table is difficult. After some searches, this is the only method I found that works:

Sub Extract()    Dim doc As Object
    Dim tbl As Object
    
    Set doc = ActiveInspector.WordEditor
    Set tbl = doc.Tables(1)
    
    'From here I can use tbl.Range.Copy to move the data in to an excel sheet
End Sub

The problem with this is that it needs to be in an Inspector window (mail item needs to be open) to work. I can't just be selecting the mail item and run the macro, and more importantly, I can't setup a Rule in outlook to run this script whenever an e-mail with a specific subject line is received.

One option is to have the script open the mail item, extract the info, then close it. But that may get disruptive if the user is working on other things throughout the day and mail items are randomly being opened and closed.

Any suggestions?

Thanks!

 

[VBA Geek]

Each mailItem in outlook has an HTMLBody property which returns a HTML string of the message. If you want to import a table in excel then you can exploit this and use MSHTML.HTMLDocument to import your table as per below

you need to update the email address and also i am setting my mailItem to the last email received in my folder "inbox", so you need to modify these

ps you need to a reference for Outlook and another called MICROSOFT HTML OBJECT LIBRARY

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

 

[SeanDamnit]

excellent, VBA Geek. I really appreciate the help.

 

[nakoshirk]

Hi VBA Geek,

Thank you for this code.

The code is working very much fine but the code is only copying the HTML data for the last mail in the mail box.

Please could you suggest how can I get all the data in the folder.

Thanks & Regards,
Koushik

 

[yasseraaali]

could anyone tell me how to do this step by step?

 

[farhan814]

Hello,

I've trying to figure out regarding to export all tables from Outlook email to excel sheet, the scenario is as under

I've an outlook folder name "Out" where only one email presents at a time which contains data in multiple tables and each table has different format(Row and Columns).

What i need is an excel macro which can copy each table with data and paste it in excel single sheet as it is one after another.

Kindly support to do so.

 

[jpsil105]

Each mailItem in outlook has an HTMLBody property which returns a HTML string of the message. If you want to import a table in excel then you can exploit this and use MSHTML.HTMLDocument to import your table as per below

you need to update the email address and also i am setting my mailItem to the last email received in my folder "inbox", so you need to modify these

ps you need to a reference for Outlook and another called MICROSOFT HTML OBJECT LIBRARY

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

Would anyone able to help me, I got this code to work exporting tables from an outlook folder however it just keeps over writing each e-mails data with the next.
I need it to remember where it ended to start adding data from the next table.


Sub outlook_import_emailbody()
On Error Resume Next

Dim O As Outlook.Application
Set O = New Outlook.Application

Dim ONS As Outlook.Namespace
Set ONS = O.GetNamespace("MAPI")
Dim MYFOL As Outlook.Folder
Set MYFOL = ONS.Folders("*********@*****.com").Folders("VO")
Dim OMAIL As Outlook.MailItem
Set OMAIL = O.CreateItem(olMailItem)

For Each OMAIL In MYFOL.Items
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.innerText
Next y
Next x


Next OMAIL
Set oApp = Nothing
Set oMapi = Nothing
Set OMAIL = Nothing
Set oHTML = Nothing
Set oElColl = Nothing

End Sub