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. Thank you very much for everything thus far. It is definitely a lot of help!

 

[Domenic]

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?

 

[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?

It still for some reason is only displaying two rows of information of two tables relating to the same email thread from a while back.

Is there a way to have it go through the subfolder, and perhaps only grab tables from emails that contain a certain string?

Usually, the emails that contain the table have a string of text right above the table in the email body, saying something like "below is the information" and its always the same string. Is it possible to filter those emails only in the subfolder? Maybe that would help with the table extraction?

 

[MrHelpcel]

Oh, I think it may have worked, but the excel file had a huge amount of empty cells so I had to keep scrolling down to find the next records. For some reason they aren't in a row-by-row format. I'll see if I can somehow count the number of rows that are filled up when I get back home and compare that with the number of emails we have.

 

[Domenic]

Does the table itself contain a string or value by which it can be identified? Maybe a specific header? Or, maybe a specific text? Or, maybe certain number of columns. Or, maybe something else?

 

[MrHelpcel]

Does the table itself contain a string or value by which it can be identified? Maybe a specific header? Or, maybe a specific text? Or, maybe certain number of columns. Or, maybe something else?

Sorry for the late reply.

The table is always comprised of two columns and 18 rows (the left column acts as headers, whereas the right column displays the data for each row). As such, the left column always has the same headers as text inside the column.

Would it also be possible to gather things like the date the email was received and add it as another cell to the excel row? Or the subject of the email? Those happen to have important data that could be useful to have.

FYI, the code per se works, it just seems to be spread out throughout the excel file (for example, in rows 1 and 2 I'll find two sets of data from tables from an email thread, but then the next data for another email isn't seen until row 10, so to speak). Is there a way around this?

 

[MrHelpcel]

Sorry for the late reply.

The table is always comprised of two columns and 18 rows (the left column acts as headers, whereas the right column displays the data for each row). As such, the left column always has the same headers as text inside the column.

Would it also be possible to gather things like the date the email was received and add it as another cell to the excel row? Or the subject of the email? Those happen to have important data that could be useful to have.

FYI, the code per se works, it just seems to be spread out throughout the excel file (for example, in rows 1 and 2 I'll find two sets of data from tables from an email thread, but then the next data for another email isn't seen until row 10, so to speak). Is there a way around this

 

[Domenic]

Okay, I have amended the code, and so it now checks to makes sure that the first cell from the first column of the table contains the specified header/text before proceeding to retrieve the data. And it enters the received time in Column A, the subject in Column B, and the rest of the data in Columns C, D, E, etc.

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
                If oTable.Cells(0, 0).innerText = "HeaderName" Then 'change the header/text accordingly
                    Cells(nextRow, "A").Value = oMail.ReceivedTime
                    Cells(nextRow, "B").Value = oMail.Subject
                    For x = 0 To oTable.Rows.Length - 1
                        Cells(nextRow, "C").Offset(, x).Value = oTable.Rows(x).Cells(1).innerText
                    Next x
                    nextRow = nextRow + 1
                End If
            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]

It ran the first time,

Okay, I have amended the code, and so it now checks to makes sure that the first cell from the first column of the table contains the specified header/text before proceeding to retrieve the data. And it enters the received time in Column A, the subject in Column B, and the rest of the data in Columns C, D, E, etc.

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
                If oTable.Cells(0, 0).innerText = "HeaderName" Then 'change the header/text accordingly
                    Cells(nextRow, "A").Value = oMail.ReceivedTime
                    Cells(nextRow, "B").Value = oMail.Subject
                    For x = 0 To oTable.Rows.Length - 1
                        Cells(nextRow, "C").Offset(, x).Value = oTable.Rows(x).Cells(1).innerText
                    Next x
                    nextRow = nextRow + 1
                End If
            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

It ran and compiled a lot of the emails, but for some reason it seems to be missing a lot of them, too. I had a runtime error at one point in the Set oMapi line, but it managed to run after a few tries. 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?)

 

[MrHelpcel]

To give a small example. The number of "cases" should be around 800, but excel is recording just under 400 of them.