Excel Vba Extract Table from Outlook message body if string exists in subject

[yousufj56]

I have the following code for extracting tables from Outlook email. However it only looks at the latest email. I need it to be able match string in the subject of the email in order to identify which email to extract the table from. Can someone please let me know what I need to add to the code below?

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">Option Explicit

Sub impOutlookTable()

Dim wkb As Workbook
Set wkb = Workbooks.Add

Sheets("Sheet1").Cells.ClearContents

' point to the desired email
Const strMail AsString="first.last@outlook.com"

Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem

OnErrorResumeNext
Set oApp = GetObject(,"OUTLOOK.APPLICATION")
If(oApp IsNothing)ThenSet oApp = CreateObject("OUTLOOK.APPLICATION")

OnErrorGoTo0

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")
EndWith

'import in Excel
Dim x AsLong, y AsLong
For x =0To oElColl(0).Rows.Length -1
For y =0To 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

wkb.SaveAs "C:\Users\user\.spyder-py3\Outlook\tables.xlsx"

EndSub</code>

 

[yousufj56]

So far i've managed to get it to look to see if the subject line exists. But its still extracting the table from the most recent email. I want it to extract the email from the item with the specified subject line.

Here is my code. Any help would be appreciated:

Option Explicit


Sub impOutlookTable()


Dim wkb As Workbook
Set wkb = Workbooks.Add


Sheets("Sheet1").Cells.ClearContents


' point to the desired email
Const strMail As String = "some.email@email.ca"


Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long


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").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)


For i = 1 To oMapi.Items.Count
If oMapi.Items.item(i).Subject = "SUBJECT HERE" Then


' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable


Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oMail.HTMLBody
Set tables = .getElementsByTagName("table")
End With


'import in 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.innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next
End If
Next


Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing


wkb.SaveAs "C:\Users\user\.spyder-py3\Outlook\tables.xlsx"


End Sub

 

[Domenic]

To search for a specific subject, try...

Dim oItem As Object

For Each oItem In oMapi.Items
    If oItem.Subject = "Subject" Then
        Exit For
    End If
Next oItem


If Not oItem Is Nothing Then
    'extract table from mail item
    '
    '
    '
End If

If you don't want the search to be case-sensitive, replace...

If oItem.Subject = "Subject" Then

with

If UCase(oItem.Subject) = "SUBJECT" Then

Hope this helps!

 

[yousufj56]

Thanks for the reply. This still only extracts the most current email that contains a table. Not the email with the specified subject line.

Could there be an issue with the extract table part of my code? I've included it above.

 

[Domenic]

Can you post the exact code you're using, including the changes?

 

[yousufj56]

Option Explicit




Sub impOutlookTable()




Dim wkb As Workbook
Set wkb = Workbooks.Add




Sheets("Sheet1").Cells.ClearContents




' point to the desired email
Const strMail As String = "some.user@email.ca"




Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object




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").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)




For Each oItem In oMapi.Items
    If oItem.Subject = "FW: Contract Change Notification - July 8, 2018 to July 14, 2018" Then
    
            Exit For
    End If
Next oItem


If Not oItem Is Nothing Then


' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable




Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oMail.HTMLBody
Set tables = .getElementsByTagName("table")
End With




'import in 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
End If




Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing




wkb.SaveAs "C:\Users\user\.spyder-py3\Outlook\tables.xlsx"




End Sub

 

[Domenic]

You'll need to replace...

.Body.innerHTML = oMail.HTMLBody

with

.Body.innerHTML = oItem.HTMLBody

And, of course, you can delete any reference to oMail. So you can delete this line...

[COLOR=#574123]Dim oMail As Outlook.MailItem[/COLOR]

And you can replace...

[COLOR=#574123]Set oMail = Nothing[/COLOR]

with

[COLOR=#574123]Set oItem = Nothing[/COLOR]

 

[yousufj56]

Amazing! It works perfectly now. Thanks for all your help

 

[Nidhi24]

Amazing! It works perfectly now. Thanks for all your help

How do i loop through all the emails with the same subject and extract information? When i use this code, I am able to extract only the first occurrence based on the subject. I have multiple emails with the same subject and want to extract all those emails. How do i do that?