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

M

MrHelpcel

New Member
Joined
Jan 21, 2022
Messages
32
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2011
  7. 2010
  8. 2007
  9. 2003 or older
Platform
  1. Windows
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:

VBA Code: 
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.
 
Sort by date Sort by votes
Okay. Thank you very much for everything thus far. It is definitely a lot of help!
 
Upvote 0

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
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...

VBA 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
    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?
 
Last edited:
Upvote 0
Domenic said:
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...

VBA 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
    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?
Click to expand...
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?
 
Upvote 0
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.
 
Upvote 0
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?
 
Upvote 0
Domenic said:
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?
Click to expand...
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?
 
Upvote 0
MrHelpcel said:
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
Click to expand...
 
Upvote 0
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.

VBA 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
                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
 
Upvote 0
It ran the first time,
Domenic said:
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.

VBA 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
                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
Click to expand...
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?)
 
Upvote 0
To give a small example. The number of "cases" should be around 800, but excel is recording just under 400 of them.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Solved
Copy Outlook Email HTML Body as Table to Excel
Replies
6
Views
1K
E1375
E
H
  • Question Question
VBA is centering the image instead of aligning it to the left as usual in New Email
Replies
1
Views
215
Micron
M
H
  • Question Question
Flagged Emails
Replies
2
Views
49
howard
H
B
  • Question Question
font size in outlook email (12 points doesn't work)
2
Replies
13
Views
330
basb87
B
J
  • Question Question
VBA Email as PDF
Replies
6
Views
115
j4ymf
J

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top