Outlook/VBA - Extracting tables from all emails in a specific folder

[MrHelpcel]

Hey all,

I have come across a problem, and after scouring google and this website, I have come close, but still not quite where I want to be. For reference, I know almost nothing of VBA but I can somewhat follow the code logic, although its still not enough to come with a solution for my problem.

Currently, my company sends out automated emails to another business. This business then replies to the automated email with a sort of acknowledgement message, and then replies with a second email that contains a table composed of two columns and 18 rows (the first column is always the same, as its the "header" of each row. The second one contains the data that changes).

We receive many of these emails a day and I wanted to compile a list of all of them. As of right now, all of these emails are stored in an outlook subfolder within a shared company email. The way I wanted to compile them was by having every email with that table record that data in a single row in Excel, and then move on to the next row and record the next table it found. (The table is HTML)

I have used many resources online, but I come across issues, and would like some help to try and resolve the issue. This is the current code I have running:

Sub demo()


Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim oHTML As MSHTML.HTMLDocument
Dim oElColl As MSHTML.IHTMLElementCollection
Dim destCell As Range
    Dim x As Long, y As Long

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("folder1").Folders("folder2").Folders("folder3").Folders("folder4")
Set oMail = oMapi.Items(oMapi.Items.Count)



For Each oMail In oMapi.Items
    Set oHTML = New MSHTML.HTMLDocument
    With oHTML
        .Body.innerHTML = oMail.HTMLBody
        Set oElColl = .getElementsByTagName("table")
    End With


    For Each table In oElColl
        For x = 0 To oElColl(0).Rows.Length - 1
            For y = 0 To oElColl(0).Rows(x).Cells.Length - 1
                If y = 1 Then
                    ActiveCell.Offset(y, x).Value = oElColl(0).Rows(x).Cells(y).innerText
                End If
            Next y
        Next x
        
    Next
Next


Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set oHTML = Nothing
Set oElColl = Nothing
End Sub

The code seems to be running through different emails, and it takes a while to finish running (a few minutes, due to im guessing the number of emails in this subfolder, which I have named folder1 through 4 because I'd prefer not to share), but at the end of execution, only the latest email appears on the excel file.

How can I resolve this issue? Any help would be greatly appreciated, as I have to compile this file and the number of tables I would have to manually input would be daunting, to say the least.

 

[MrHelpcel]

Bumping. I could really use some help here with this

 

[Domenic]

Try the following macro, which should resolve your issue. Also, I have made the following amendments . . .

1. Added error handling, in case Outlook is not available.
2. Removed Set oMail = oMapi.Items(oMapi.Items.Count) since it's not needed.
3. Added error handling, in case the folder contains an object other than a MailItem, such as a MeetingItem, etc.
4. Eliminated the inner-most For/Next loop to make it more efficient.
5. Re-named the variable oElColl to oTables for clarity.

Here's the code . . .

Sub demo()

    Dim oApp As Outlook.Application
    Dim oMapi As Outlook.MAPIFolder
    Dim oMail As Outlook.MailItem
    Dim oItem As Variant
    Dim oHTML As MSHTML.HTMLDocument
    Dim oTable As MSHTML.HTMLTable
    Dim oTables As MSHTML.IHTMLElementCollection
    Dim nextRow As Long
    Dim x As Long
 
    On Error Resume Next
    Set oApp = GetObject(, "Outlook.Application")
    If oApp Is Nothing Then
        Set oApp = CreateObject("Outlook.Application")
        If oApp Is Nothing Then
            MsgBox "Unable to start Outlook!", vbExclamation, "Outlook"
            Exit Sub
        End If
    End If
    On Error GoTo 0
 
    Set oMapi = oApp.GetNamespace("MAPI").Folders("folder1").Folders("folder2").Folders("folder3").Folders("folder4")
 
    nextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
 
    For Each oItem In oMapi.Items
        If TypeName(oItem) = "MailItem" Then
            Set oMail = oItem
            Set oHTML = New MSHTML.HTMLDocument
            With oHTML
                .Body.innerHTML = oMail.HTMLBody
                Set oTables = .getElementsByTagName("table")
            End With
            For Each oTable In oTables
                For x = 0 To oTable.Rows.Length - 1
                    Cells(nextRow, "A").Offset(0, x).Value = oTable.Rows(x).Cells(1).innerText
                Next x
                nextRow = nextRow + 1
            Next oTable
            Set oHTML = Nothing
            Set oMail = Nothing
        End If
    Next oItem
 
    Set oApp = Nothing
    Set oMapi = Nothing
    Set oMail = Nothing
    Set oHTML = Nothing
    Set oTable = Nothing
    Set oTables = Nothing
 
End Sub

Hope this helps!

 

[MrHelpcel]

Try the following macro, which should resolve your issue. Also, I have made the following amendments . . .

1. Added error handling, in case Outlook is not available.
2. Removed Set oMail = oMapi.Items(oMapi.Items.Count) since it's not needed.
3. Added error handling, in case the folder contains an object other than a MailItem, such as a MeetingItem, etc.
4. Eliminated the inner-most For/Next loop to make it more efficient.
5. Re-named the variable oElColl to oTables for clarity.

Here's the code . . .

Sub demo()

    Dim oApp As Outlook.Application
    Dim oMapi As Outlook.MAPIFolder
    Dim oMail As Outlook.MailItem
    Dim oItem As Variant
    Dim oHTML As MSHTML.HTMLDocument
    Dim oTable As MSHTML.HTMLTable
    Dim oTables As MSHTML.IHTMLElementCollection
    Dim nextRow As Long
    Dim x As Long
 
    On Error Resume Next
    Set oApp = GetObject(, "Outlook.Application")
    If oApp Is Nothing Then
        Set oApp = CreateObject("Outlook.Application")
        If oApp Is Nothing Then
            MsgBox "Unable to start Outlook!", vbExclamation, "Outlook"
            Exit Sub
        End If
    End If
    On Error GoTo 0
 
    Set oMapi = oApp.GetNamespace("MAPI").Folders("folder1").Folders("folder2").Folders("folder3").Folders("folder4")
 
    nextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
 
    For Each oItem In oMapi.Items
        If TypeName(oItem) = "MailItem" Then
            Set oMail = oItem
            Set oHTML = New MSHTML.HTMLDocument
            With oHTML
                .Body.innerHTML = oMail.HTMLBody
                Set oTables = .getElementsByTagName("table")
            End With
            For Each oTable In oTables
                For x = 0 To oTable.Rows.Length - 1
                    Cells(nextRow, "A").Offset(0, x).Value = oTable.Rows(x).Cells(1).innerText
                Next x
                nextRow = nextRow + 1
            Next oTable
            Set oHTML = Nothing
            Set oMail = Nothing
        End If
    Next oItem
 
    Set oApp = Nothing
    Set oMapi = Nothing
    Set oMail = Nothing
    Set oHTML = Nothing
    Set oTable = Nothing
    Set oTables = Nothing
 
End Sub

Hope this helps!

Thank you for your reply!

For some reason, however, it is throwing a run-time error "424": object required, and only grabbing two tables from an email near the start of the folder with all the emails. Do you know how I could fix this?

 

[MrHelpcel]

For reference,

I had initially adapted the code from here:

Parse Table in Email Body to Excel

social.msdn.microsoft.com

Which seemed to work in getting the last one. Then I tried to make it loop through the whole folder but it didnt work out, and I tried mixing it in with code from other sources.

 

[Domenic]

Which line is giving you the error?

 

[MrHelpcel]

Which line is giving you the error?

After it goes through Next oTable once, it loops back to start the second whole iteration of For Each oTable In oTables and throws the runtime error after going through "Cells(nextRow, "A").Offset(0, x).Value = oTable.Rows(x).Cells(1).innerText"

 

[Domenic]

The error on that line would suggest that oTables has not been defined. However, if that's the case, you would have gotten an error at the start of the first iteration. So something doesn't quite make sense.

Did you copy and paste my code as is, and in its entirety? Or did you make any changes? If the latter, can you post the exact code you're using?

 

[MrHelpcel]

Copied and pasted it in its entirety. It only ran through two tables (both were tables from the same email thread, but two separate emails, if that makes sense. One was an initial table with data regarding an ongoing issue, and then we got another email with the same table format but with different data for when the issue was resolved)

 

[Domenic]

I'm not sure where the problem lies. However, I did test the code prior to posting it, and it seemed to run fine.

I'm logging off at the moment, but I will look at this again as soon as I get a chance.