How to loop Outlook emails with particular subject line? - excel

Question

I have code that extracts the body of email which has the subject line "Volume data".
Let's say I have 10 emails in my inbox folder which has the subject line "Volume data".
I want to loop through all the emails, find which email has subject line "Volume data" and then extract the email body from those 10 emails.
My code is stopping at the first instance where it finds the mentioned subject.
Option Explicit
Sub impOutlookTable()
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.ClearContents
' point to the desired email
Const strMail As String = "emailaddress"
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 = "Volume data" 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 = oItem.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\Desktop\New_email.xlsm"
End Sub

Answer 1

Put all of the "Action" code inside the If statement inside your loop instead of after it, and then remove the Exit For.
You will also need a counter or something so that you aren't just saving overtop of the same file for each iteration.
UNTESTED
Option Explicit
Sub impOutlookTable()
Dim iCounter As Integer
iCounter = 1
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.ClearContents
' point to the desired email
Const strMail As String = "emailaddress"
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 = "Volume data" 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 = oItem.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
Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.SaveAs "C:\Users\Desktop\New_email_" & iCounter & ".xlsm"
iCounter = iCounter + 1
End If
Next oItem
End Sub