How to loop in for all outlook emails with particular subject line instead of just one email using m-CodePudding

I have a code that extracts the body of the email only for those email which has the subject line as "Volume data". Let's say I have 10 emails in my inbox folder which has the subject line as "Volume data". I want to loop through all the emails, find which email has subject line as "Volume data" and then extract email body only from those 10 emails. Right now my code is stopping at the first instance where it finds the mentioned subject and not looping through my entire inbox. I am posting my code below. Any help would be greatly appreciated.

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

CodePudding user response：

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