VBA to extract data from outlook mails

N

Nidhi24

New Member
Joined
Nov 1, 2021
Messages
9
Office Version
  1. 2019
Platform
  1. Windows
I have a VBA code that extracts table data from outlook emails but from a particular subfolder. I want to generalize my code and instead of searching in a particular subfolder under "Inbox", I want the code to filter the emails directly from the "Inbox" folder and then extract the tables from the same. Can someone help me figure out a way to do so?
Posting the code below for reference. Any help would be greatly appreciated.

VBA Code: 
Option Explicit

Sub ImportTable()

Cells.Clear
Dim OLApp As Outlook.Application
'Set OA = CreateObject("Outlook.Application")
Set OLApp = New Outlook.Application

Dim ONS As Outlook.Namespace
Set ONS = OLApp.GetNamespace("MAPI")
Dim myFolder As Outlook.Folder
Set myFolder = ONS.Folders("emailaddress").Folders("Inbox")
Set myFolder = myFolder.Folders("Others")
Dim OLMAIL As Outlook.MailItem
Set OLMAIL = OLApp.CreateItem(olMailItem)
Dim olkMsg As Object
Dim intRow As Integer

For Each OLMAIL In myFolder.Items
    Dim oHTML As MSHTML.HTMLDocument
    Set oHTML = New MSHTML.HTMLDocument
    Dim oElColl As MSHTML.IHTMLElementCollection
With oHTML
    .Body.innerHTML = OLMAIL.HTMLBody
    Set oElColl = .getElementsByTagName("table")
End With


'For Each olkMsg In OLMAIL
        'If olkMsg.Subject Like "FW: Custody WFM Needs Analysis: Snapshot" Then
   
Dim t As Long, r As Long, c As Long
Dim eRow As Long

    For t = 0 To oElColl.Length - 1
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        For r = 0 To (oElColl(t).Rows.Length - 1)
            For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                Range("A" & eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
            Next c
        Next r
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        Next t
       
        'Cells(eRow, 1) = "Sender's Name:" & " " & OLMAIL.Sender
        'Cells(eRow, 1).Interior.Color = vbRed
        'Cells(eRow, 1).Font.Color = vbWhite
        Cells(eRow, 1) = "Date & Time of Receipt:" & " " & OLMAIL.ReceivedTime
        Cells(eRow, 1).Interior.Color = vbRed
        Cells(eRow, 1).Font.Color = vbWhite
        Cells(eRow, 1).Columns.AutoFit
       
Next OLMAIL

Range("A1").Select

Set OLApp = Nothing
Set OLMAIL = Nothing
Set oHTML = Nothing
Set oElColl = Nothing

On Error Resume Next
Range("A1:A" & Worksheets(1).UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'ThisWorkbook.VBProject.VBE.MainWindow.Visible = False

End Sub
 
Last edited by a moderator:

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Sort by date Sort by votes
Haven't looked at your code further, but I think removing one line of code will get your inbox used.

ScreenShot271.jpg
 
Upvote 0
GWteB said:
Haven't looked at your code further, but I think removing one line of code will get your inbox used.

View attachment 50268
Click to expand...
Thanks for the reply. Yes, this would take me to the inbox folder. But what I am looking for is how do i filter the emails in inbox based on the subject of the email. Let's say for eg: I have 10 emails in my inbox with the subject as "Volume data". How do i extract data only from those emails which has the subject line as "Volume data". Any help would be greatly appreciated.
 
Upvote 0
I see. I have modified the first part of your code regarding the email subject. I'm afraid I can't judge the rest of your code for proper operation.

VBA Code: 
Sub ImportTable()

    Cells.Clear
    Dim OLApp As Outlook.Application
    Set OLApp = New Outlook.Application

    Dim ONS As Outlook.NameSpace
    Set ONS = OLApp.GetNamespace("MAPI")
    Dim myFolder As Outlook.Folder
    Set myFolder = ONS.Folders("emailaddress").Folders("Inbox")

    If myFolder.Items.Count > 0 Then        ' << are there items at all?

        Dim OLMAIL As Outlook.MailItem
        For Each OLMAIL In myFolder.Items   ' << iterate all items
        
            If StrComp(OLMAIL.Subject, "volume data", vbTextCompare) = 0 Then    ' << does subject of current item meet criterion?

' ==========================================================================
' >>>> I cannot judge whether or not the code below works correctly.  <<<<<
' ==========================================================================
                
                Dim oHTML As MSHTML.HTMLDocument
                Set oHTML = New MSHTML.HTMLDocument
                Dim oElColl As MSHTML.IHTMLElementCollection
                With oHTML
                    .Body.innerHTML = OLMAIL.HTMLBody
                    Set oElColl = .getElementsByTagName("table")
                End With
                
                Dim intRow As Integer
                Dim t As Long, r As Long, c As Long
                Dim eRow As Long

                For t = 0 To oElColl.Length - 1
                    eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    For r = 0 To (oElColl(t).Rows.Length - 1)
                        For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                            Range("A" & eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
                        Next c
                    Next r
                    eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                Next t
       
                'Cells(eRow, 1) = "Sender's Name:" & " " & OLMAIL.Sender
                'Cells(eRow, 1).Interior.Color = vbRed
                'Cells(eRow, 1).Font.Color = vbWhite
                Cells(eRow, 1) = "Date & Time of Receipt:" & " " & OLMAIL.ReceivedTime
                Cells(eRow, 1).Interior.Color = vbRed
                Cells(eRow, 1).Font.Color = vbWhite
                Cells(eRow, 1).Columns.AutoFit

            End If
        Next OLMAIL
    End If
    Range("A1").Select

    Set OLApp = Nothing
    Set OLMAIL = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing

    On Error Resume Next
    Range("A1:A" & Worksheets(1).UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    'ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
End Sub
 
Upvote 0
GWteB said:
I see. I have modified the first part of your code regarding the email subject. I'm afraid I can't judge the rest of your code for proper operation.

VBA Code: 
Sub ImportTable()

    Cells.Clear
    Dim OLApp As Outlook.Application
    Set OLApp = New Outlook.Application

    Dim ONS As Outlook.NameSpace
    Set ONS = OLApp.GetNamespace("MAPI")
    Dim myFolder As Outlook.Folder
    Set myFolder = ONS.Folders("emailaddress").Folders("Inbox")

    If myFolder.Items.Count > 0 Then        ' << are there items at all?

        Dim OLMAIL As Outlook.MailItem
        For Each OLMAIL In myFolder.Items   ' << iterate all items
       
            If StrComp(OLMAIL.Subject, "volume data", vbTextCompare) = 0 Then    ' << does subject of current item meet criterion?

' ==========================================================================
' >>>> I cannot judge whether or not the code below works correctly.  <<<<<
' ==========================================================================
               
                Dim oHTML As MSHTML.HTMLDocument
                Set oHTML = New MSHTML.HTMLDocument
                Dim oElColl As MSHTML.IHTMLElementCollection
                With oHTML
                    .Body.innerHTML = OLMAIL.HTMLBody
                    Set oElColl = .getElementsByTagName("table")
                End With
               
                Dim intRow As Integer
                Dim t As Long, r As Long, c As Long
                Dim eRow As Long

                For t = 0 To oElColl.Length - 1
                    eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    For r = 0 To (oElColl(t).Rows.Length - 1)
                        For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                            Range("A" & eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
                        Next c
                    Next r
                    eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                Next t
      
                'Cells(eRow, 1) = "Sender's Name:" & " " & OLMAIL.Sender
                'Cells(eRow, 1).Interior.Color = vbRed
                'Cells(eRow, 1).Font.Color = vbWhite
                Cells(eRow, 1) = "Date & Time of Receipt:" & " " & OLMAIL.ReceivedTime
                Cells(eRow, 1).Interior.Color = vbRed
                Cells(eRow, 1).Font.Color = vbWhite
                Cells(eRow, 1).Columns.AutoFit

            End If
        Next OLMAIL
    End If
    Range("A1").Select

    Set OLApp = Nothing
    Set OLMAIL = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing

    On Error Resume Next
    Range("A1:A" & Worksheets(1).UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    'ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
End Sub
Click to expand...
Thanks for your help.
 
Upvote 0
GWteB said:
I see. I have modified the first part of your code regarding the email subject. I'm afraid I can't judge the rest of your code for proper operation.

VBA Code: 
Sub ImportTable()

    Cells.Clear
    Dim OLApp As Outlook.Application
    Set OLApp = New Outlook.Application

    Dim ONS As Outlook.NameSpace
    Set ONS = OLApp.GetNamespace("MAPI")
    Dim myFolder As Outlook.Folder
    Set myFolder = ONS.Folders("emailaddress").Folders("Inbox")

    If myFolder.Items.Count > 0 Then        ' << are there items at all?

        Dim OLMAIL As Outlook.MailItem
        For Each OLMAIL In myFolder.Items   ' << iterate all items
       
            If StrComp(OLMAIL.Subject, "volume data", vbTextCompare) = 0 Then    ' << does subject of current item meet criterion?

' ==========================================================================
' >>>> I cannot judge whether or not the code below works correctly.  <<<<<
' ==========================================================================
               
                Dim oHTML As MSHTML.HTMLDocument
                Set oHTML = New MSHTML.HTMLDocument
                Dim oElColl As MSHTML.IHTMLElementCollection
                With oHTML
                    .Body.innerHTML = OLMAIL.HTMLBody
                    Set oElColl = .getElementsByTagName("table")
                End With
               
                Dim intRow As Integer
                Dim t As Long, r As Long, c As Long
                Dim eRow As Long

                For t = 0 To oElColl.Length - 1
                    eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                    For r = 0 To (oElColl(t).Rows.Length - 1)
                        For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                            Range("A" & eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
                        Next c
                    Next r
                    eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
                Next t
      
                'Cells(eRow, 1) = "Sender's Name:" & " " & OLMAIL.Sender
                'Cells(eRow, 1).Interior.Color = vbRed
                'Cells(eRow, 1).Font.Color = vbWhite
                Cells(eRow, 1) = "Date & Time of Receipt:" & " " & OLMAIL.ReceivedTime
                Cells(eRow, 1).Interior.Color = vbRed
                Cells(eRow, 1).Font.Color = vbWhite
                Cells(eRow, 1).Columns.AutoFit

            End If
        Next OLMAIL
    End If
    Range("A1").Select

    Set OLApp = Nothing
    Set OLMAIL = Nothing
    Set oHTML = Nothing
    Set oElColl = Nothing

    On Error Resume Next
    Range("A1:A" & Worksheets(1).UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    'ThisWorkbook.VBProject.VBE.MainWindow.Visible = False
End Sub
Click to expand...
The code works perfectly well! The only thing is, if I have just one email in my Inbox the line "Next OLMAIL" throws an error as 'Type Mismatch'. Any idea how to resolve it?
 
Upvote 0
Apparently there is another kind of item in that folder. A code change like the one below might resolve this issue.
Note that because a new If ... Then instruction is added to the code an associated End If must be added at the end of the block as well.

Change this snippet ...
Rich (BB code): 
    If myFolder.Items.Count > 0 Then        ' << are there items at all?

        Dim OLMAIL As Outlook.MailItem
        For Each OLMAIL In myFolder.Items   ' << iterate all items
        
            If StrComp(OLMAIL.Subject, "volume data", vbTextCompare) = 0 Then    ' << does subject of current item meet criterion?

... into this:
Rich (BB code): 
    If myFolder.Items.Count > 0 Then        ' << are there items at all?

        Dim OLMAIL As Object
        For Each OLMAIL In myFolder.Items   ' << iterate all items

            If TypeOf OLMAIL Is MailItem Then
                If StrComp(OLMAIL.Subject, "volume data", vbTextCompare) = 0 Then    ' << does subject of current item meet criterion?

& don't forget the closing End If
 
Upvote 0
GWteB said:
Apparently there is another kind of item in that folder. A code change like the one below might resolve this issue.
Note that because a new If ... Then instruction is added to the code an associated End If must be added at the end of the block as well.

Change this snippet ...
Rich (BB code): 
    If myFolder.Items.Count > 0 Then        ' << are there items at all?

        Dim OLMAIL As Outlook.MailItem
        For Each OLMAIL In myFolder.Items   ' << iterate all items
       
            If StrComp(OLMAIL.Subject, "volume data", vbTextCompare) = 0 Then    ' << does subject of current item meet criterion?

... into this:
Rich (BB code): 
    If myFolder.Items.Count > 0 Then        ' << are there items at all?

        Dim OLMAIL As Object
        For Each OLMAIL In myFolder.Items   ' << iterate all items

            If TypeOf OLMAIL Is MailItem Then
                If StrComp(OLMAIL.Subject, "volume data", vbTextCompare) = 0 Then    ' << does subject of current item meet criterion?

& don't forget the closing End If
Click to expand...
Thankyou so much!
 
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
R
  • Question Question
VBA - AUTO FIT, Can we remove make the sum formula in below code
Replies
1
Views
157
Joe4
Joe4
K
  • Question Question
VBA DOUBT- can we add heading color and remove blank columns in this code?
Replies
0
Views
162
Kishore1982
K
K
  • Question Question
Can you please explain why this code getting error while running
Replies
2
Views
231
Joe4
Joe4
K
  • Question Question
Reverse Engineer Outlook Macro since New Outlook does not allow Macros
Replies
1
Views
355
John_w
J

Forum statistics

Threads
1,223,886
Messages
6,175,196
Members
452,616
Latest member
intern444

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