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]

Okay, I think I see where the problem lies. I think the error occurs when a table only contains one column. So I have changed part of the code back to your original code. Try the following instead...

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
    Dim y 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
  
    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
                    For y = 0 To oTable.Rows(x).Cells.Length - 1
                        If y = 1 Then
                            Cells(nextRow, "A").Offset(y, x).Value = oTable.Rows(x).Cells(y).innerText
                        End If
                    Next y
                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

Does this help?

Interestingly enough, this piece of code might have all of the cases, it just happens to be missing the Date/Subject title, and the rows aren't one after another. Whereas the latest piece of code you gave me has all the data in rows one after another, and has the date/subject title. Is there a way to add those to the code above? And omit the "search by header of first row in first column of table" part?

I know I am asking for a lot, and I am very sorry about that. So far though, this has been the closest I have gotten to it and you cannot believe how incredibly thankful I am for it. It is saving me and a lot of people a LOT of manual work that we simply don't have available at the moment.

 

[Domenic]

It still seems to be having the issue of not collecting all of the emails though, despite the table seemingly being the same in terms of header (maybe they added a space or something to the header, which screws up the search?)

Does it help if you replace . . .

If oTable.Cells(0, 0).innerText = "HeaderName" Then

with

If LCase(Trim(oTable.Cells(0, 0).innerText)) = "headername" Then 'removes leading and trailing space, and makes the comparison non-case-sensitive (make sure the text 'headername' is all in lower case)

Is there a way to add those to the code above? And omit the "search by header of first row in first column of table" part?

Does this help?

Option Explicit

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
    Dim y 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")
    Set oMapi = oApp.GetNamespace("MAPI").Folders("domtamb22@gmail.com").Folders("Drafts")
   
    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
                    For y = 0 To oTable.Rows(x).Cells.Length - 1
                        If y = 1 Then
                            Cells(nextRow, "A").Value = oMail.ReceivedTime
                            Cells(nextRow, "B").Value = oMail.Subject
                            Cells(nextRow, "C").Offset(y - 1, x).Value = oTable.Rows(x).Cells(y).innerText
                        End If
                    Next y
                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

 

[MrHelpcel]

Does it help if you replace . . .

If oTable.Cells(0, 0).innerText = "HeaderName" Then

with

If LCase(Trim(oTable.Cells(0, 0).innerText)) = "headername" Then 'removes leading and trailing space, and makes the comparison non-case-sensitive (make sure the text 'headername' is all in lower case)

Does this help?

Option Explicit

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
    Dim y 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")
    Set oMapi = oApp.GetNamespace("MAPI").Folders("domtamb22@gmail.com").Folders("Drafts")
  
    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
                    For y = 0 To oTable.Rows(x).Cells.Length - 1
                        If y = 1 Then
                            Cells(nextRow, "A").Value = oMail.ReceivedTime
                            Cells(nextRow, "B").Value = oMail.Subject
                            Cells(nextRow, "C").Offset(y - 1, x).Value = oTable.Rows(x).Cells(y).innerText
                        End If
                    Next y
                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

I think this worked! But how come the rows of data are separated so much? I tried to use Go To Special in Excel, select all blanks, and delete them, in order to have all the rows of data one after the other, but for some reason I think its also deleting data? Because the "count" of rows that have data differ before and after. Does that make sense?

Either way, if this has all the data, this is already 95% of the objective!

 

[MrHelpcel]

I think this worked! But how come the rows of data are separated so much? I tried to use Go To Special in Excel, select all blanks, and delete them, in order to have all the rows of data one after the other, but for some reason I think its also deleting data? Because the "count" of rows that have data differ before and after. Does that make sense?

Either way, if this has all the data, this is already 95% of the objective!

I think it has to do with weird cell alignments. The data is there, sometimes it just seems to skip columns, so maybe thats what messing the data. But this is fantastic, thank you very much!

 

[Domenic]

But how come the rows of data are separated so much?

With the macro that filters the tables for a specific header, it should place the values from the second column from the first table in a row. Then it should place the values from the second column from the second table in the next row, and so on. If there are blank cells in some of the rows, could it be that some of the tables contain blank cells in the second column?

 

[MrHelpcel]

H

With the macro that filters the tables for a specific header, it should place the values from the second column from the first table in a row. Then it should place the values from the second column from the second table in the next row, and so on. If there are blank cells in some of the rows, could it be that some of the tables contain blank cells in the second column?

Hmmm, that could've been it. Either way I did some tweaking so the rows would be one after the other. Thanks a lot for all that you've done. I really cant express how thankful I am and how much youve helped me!

 

[Domenic]

That's great, I'm glad you were able to work it out.

Cheers!