Automatically export HTML Table from Outlook to Excel w/ VBA - html

Question

I'd like to export an email that contains many tables in HTML format.
Each table is something like this:
<table class="MsoNormalTable" border="0" cellspacing="0" cellpadding="0" width="100%" style="width:100.0%;background:green">...</table>
I've added a New Rule in Outlook, so everytime I receive an email with 'specific word' in the Subject, the macro runs and saves all the tables from this email to a .xlsm file. The rule itself seems to work fine, but i'm having issues to make the macro work.
I've found many topics about exporting data from Outlook to Excel and I managed to copy email's TextBody using split (in rows), but it only worked with text, not with tables.
So I started searching the web for topics about exporting Tables, and I did find one. Although, it talks about importing Tables from Outlook using Excel VBA, not exactly what i'm trying to do. I tried to edit this code in order to work when running from Outlook, but it didn't work.
References:
Here's the code:
Option Explicit
Public Sub SalvaExcel()
'This macro writes an Outlook email's body to an Excel workbook
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
'Dim TextBody As String
'Dim iArr() As String
Dim eRow As Integer
Dim xlUp As Integer
Dim i As Long
Dim j As Long
xlUp = -4162
'set email to be saved
Set olApp = Outlook.Application
Set olNameSpace = Application.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
Set olMail = olItems(olItems.Count)
'save Outlook email's html body (tables)
With olHTML
.Body.innerHTML = olMail.HtmlBody
Set olEleColl = .getElementsByTagName("table")
End With
'set excel file to be opened
FileName = "C:\Users\rafael.kobayashi\Desktop\projeto_licitacoes\Palavras-Chave.xlsm"
'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")
'in this instance
With xlApp
.Visible = True 'this slows down the macro, but helps during debugging
.ScreenUpdating = False 'reduces flash and increases speed
'open workbook
Set ExcelWkBk = xlApp.Workbooks.Open(FileName)
'in this workbook
With ExcelWkBk
'in [email] worksheet
With .Worksheets("email")
'find first empty row
'eRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
'write table in excel
Debug.Print olEleColl(0)
For i = 0 To olEleColl(0).Rows.Length - 1
For j = 0 To olEleColl(0).Rows(i).Cells.Length - 1
.Range("A1").Offset(i, j).Value = olEleColl(0).Rows(i).Cells(j).innerText
Next j
Next i
'resize columns (DO NOT)
'.Columns("B:C").AutoFit
End With
'close Workbook and save changes
.Close SaveChanges:=True
End With
'quit excel
.Quit
End With
Set xlApp = Nothing
Set ExcelWkBk = Nothing
Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing
End Sub
EDIT: There was a typo in the code, now it seems to be running, I can see that Excel opens then closes very quickly when I run the macro. However, when I open the workbook, the sheet where the tables were supposed to be is blank :(
EDIT2: I have tested the macro in an mail item where i inserted a random table and it worked, but it won't work with the tables in the mail that i showed.
EDIT3: I've found out that it wasn't working because the first table found didn't have any text in innerText, so I tested a macro that gets all the tables and it worked!

Answer 1

Change that line to this instead
For i = 0 To olEleColl(0).Rows.Length - 1
(You spelled Length wrong)

Answer 2

I've found out that it wasn't working because the first table found didn't have any text in innerText, so I tested a macro that gets all the tables and it worked!
Here's the code:
Public Sub SalvaExcel(item As Outlook.MailItem)
'This macro writes an Outlook email's tables to an Excel workbook
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim eRow As Long
Dim i As Long
Dim j As Long
Dim t
Dim posicao As String
'set email to be saved
'Set olApp = Outlook.Application
'Set olNameSpace = Application.GetNamespace("MAPI")
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
'Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
'the most recent one
'Set olMail = olItems(olItems.Count)
'save Outlook email's html body (tables)
With olHTML
.Body.innerHTML = item.HtmlBody
Set olEleColl = .getElementsByTagName("table")
End With
'set excel file to be opened
FileName = "C:\Users\rafael.kobayashi\Desktop\projeto_licitacoes\Palavras-Chave.xlsm"
'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")
'in this instance
With xlApp
.Visible = True 'if True, this slows down the macro, but helps during debugging
.ScreenUpdating = False 'if False, this reduces flash and increases speed
'open workbook
Set ExcelWkBk = xlApp.Workbooks.Open(FileName)
'in this workbook
With ExcelWkBk
'in [email] worksheet
With .Worksheets("email")
'which row to start
eRow = 1
posicao = "A" & eRow
'write each table in excel
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
'close Workbook and save changes
.Close SaveChanges:=True
End With
'quit excel
.Quit
End With
Set xlApp = Nothing
Set ExcelWkBk = Nothing
'Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing
End Sub
It exports all the tables from the last received email in the Outlook Inbox to an Excel file. It skips 1 row between one table and the next. Since it gets the most recent email and it runs from Outlook, it's useful to use in a New Rule, so it will be automatic, according to a defined criteria. I hope it helps other people!
edit: in order to run this macro in an Outlook Rule, it's necessary to give the following argument to the Sub, otherwise the macro won't be shown in the list of macros to be chosen for the Rule:
Public Sub SalvaExcel(item As Outlook.MailItem)
I have updated the code in this answer.

Answer 3

Thanks for sharing the code.
Have rectified your code to make it finally work ;)
Public Sub SalvaExcel()
'Public Sub SalvaExcel(item As Outlook.MailItem)
'This macro writes an Outlook email's tables to an Excel workbook
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFoldersDefault As Outlook.Folders
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim eRow As Long
Dim i As Long
Dim j As Long
Dim t
Dim posicao As String
'set email to be saved
'Set olApp = Outlook.Application
'Set olNameSpace = Application.GetNamespace("MAPI")
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
'Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
'Set olApp = Outlook.Application
Set olNameSpace = Application.GetNamespace("MAPI")
Set newFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olFolder = newFolder.Folders("Projects").Folders("Management").Folders("Notifications")
Set olItems = olFolder.Items
olItems.Sort ("[ReceivedTime]")
'the most recent one
Set olMail = olItems(olItems.Count)
'MsgBox olMail
'MsgBox olMail.HTMLBody
'save Outlook email's html body (tables)
With olHTML
.Body.innerHTML = olMail.HTMLBody
Set olEleColl = .getElementsByTagName("table")
End With
'set excel file to be opened
FileName = "D:\OutlookEmails.xlsm"
'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")
'in this instance
With xlApp
.Visible = True 'if True, this slows down the macro, but helps during debugging
.ScreenUpdating = False 'if False, this reduces flash and increases speed
'open workbook
Set ExcelWkBk = xlApp.Workbooks.Open(FileName)
'in this workbook
With ExcelWkBk
'in [email] worksheet
With .Worksheets("emails")
'which row to start
eRow = 1
posicao = "A" & eRow
'write each table in excel
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
'close Workbook and save changes
.Close SaveChanges:=True
End With
'quit excel
.Quit
End With
Set xlApp = Nothing
Set ExcelWkBk = Nothing
'Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing
End Sub