Import tables from multiple outlook emails

[minerva2]

Hi everyone,

We receive multiple emails from the same source during the day. They all contain a table in the same format. I would like to import the tables in the emails, starting from a specific day (e.g yesterday's date at a specific time).

I found the code below that imports the table from outlook to excel, but only from the latest email. Could you please show me how to make it copy the tables in the next emails starting from the specific date? Hopefully this makes sense.

Option Explicit

Sub impOutlookTable()

' point to the desired email
Const strMail As String = "someone@somewhere.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").GetDefaultFolder(olFolderInbox).Folders("Oliver")
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

Sheets.Add After:=ActiveSheet
ActiveSheet.Name = Format(Date, "DD-MM-YY")

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

Thank you!

 

[minerva2]

Hey guys,

Just bumping this question up in case anyone has a clue?

Thank you!