Extract first table of Outlook mail folder - excel

Question

I'm trying to extract first table of each mail of a specific folder to Excel. If there is more than one table in the mail we can exclude it and move to next mail item. Below is the code I have at the moment. Could you please help?
Public Sub Import_Tables_From_Outlook_Emails()
Dim oApp As Outlook.Application, oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem, HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection, table As MSHTML.HTMLTable
Dim objExcelApp As Excel.Application, x As Long, y As Long, destCell As Range
Dim objExcelWorkbook As Excel.Workbook, objExcelWorksheet As Excel.Worksheet
Set objExcelApp = CreateObject("Excel.Application") 'Create a new excel workbook
Set objExcelWorkbook = objExcelApp.Workbooks.Add
objExcelApp.Visible = True
Set destCell = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)
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
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
Sheets.Add After:=ActiveSheet
Range("A1").Activate
Set destCell = ActiveSheet.Range("A1")
Next
Next
End If
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
MsgBox "Finished"
End Sub

Answer 1

The following macro prompts the user to select a folder from Outlook, loops though each item in the folder, and copies the first table from each item to a separate worksheet in a newly created workbook.
Edit
The code has been edited to 1) restrict the mail items based on ReceivedTime, 2) sort the restricted items by ReceivedTime, and in descending order, 3) loop through the items from earliest to latest date.
Option Explicit
Public Sub Import_Tables_From_Outlook_Emails()
Dim oMapiFolder As Folder
Dim oMail As Object
Dim oMailItems As Object
Dim oRestrictItems As Object
Dim oHTMLDoc As Object
Dim oHTMLTable As Object
Dim xlApp As Object
Dim xlWkb As Object
Dim r As Long
Dim c As Long
Dim i As Long
Set oMapiFolder = Application.GetNamespace("MAPI").PickFolder
If oMapiFolder Is Nothing Then
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
End If
On Error GoTo 0
Set xlWkb = xlApp.workbooks.Add(-4167) 'xlWBATWorksheet
Set oHTMLDoc = CreateObject("htmlfile")
Set oMailItems = oMapiFolder.Items
Set oRestrictItems = oMailItems.Restrict("[ReceivedTime] >= '" & Format("1/1/17 12:00am", "ddddd h:nn AMPM") & "'")
oRestrictItems.Sort "[ReceivedTime]", olDescending
For i = 1 To oRestrictItems.Count
Set oMail = oRestrictItems(i)
With oHTMLDoc
.Body.innerHTML = oMail.HTMLBody
Set oHTMLTable = .getElementsByTagName("table")(0)
End With
If Not oHTMLTable Is Nothing Then
xlWkb.Worksheets.Add after:=xlWkb.activesheet
For r = 0 To oHTMLTable.Rows.Length - 1
For c = 0 To oHTMLTable.Rows(r).Cells.Length - 1
xlWkb.activesheet.Range("A1").Offset(r, c).Value = _
oHTMLTable.Rows(r).Cells(c).innerText
Next c
Next r
Set oHTMLTable = Nothing
End If
Next i
xlApp.DisplayAlerts = False
xlWkb.Worksheets(1).Delete
xlApp.DisplayAlerts = True
Application.ActiveExplorer.Activate
Set oMapiFolder = Nothing
Set oMail = Nothing
Set oHTMLDoc = Nothing
Set oHTMLTable = Nothing
Set xlApp = Nothing
Set xlWkb = Nothing
MsgBox "Finished"
End Sub