How to Extract outlook email data based on subject of the email using VBA?

Question

I have a VBA script that extracts tables from outlook emails. As of now I have a subfolder under "inbox" wherein all similar mails comes in. So the code works fine. But I want to generalize the code so that I can extract data based on the subject of the email, instead of having a dedicated subfolder for that particular email. Can someone help me out? I am posting the code below.

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)

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

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

Answer 1

If you want to deal with incoming emails look at the link to the website that I put in comment above.

If you want to deal with the current item, there is a few ways to do it. Here is one of the ways I found recently and it's awesome and I am using it! Click here to the website.

I have done a modification to suit your needs. If you have different subjects, it's sure that the content to be extract will also be different, so it inspects the current item and it runs a specific macro depending on the subject.

Paste the code in ThisOutlookSession module

Private WithEvents m_Inspectors As Outlook.Inspectors
Private WithEvents m_Inspector As Outlook.Inspector
  
Private Sub Application_Startup()
 Set m_Inspectors = Application.Inspectors
End Sub
  
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
 If TypeOf Inspector.currentItem Is Outlook.MailItem Then
  'Handle emails only
  Set m_Inspector = Inspector
 End If
End Sub
  
Private Sub m_Inspector_Activate()
    Dim Item As MailItem
    
    If TypeOf m_Inspector.currentItem Is MailItem Then
        Set Item = m_Inspector.currentItem
        
        With Item
            ' Display mail
            '.Display
            
            ' Mails with filled opions
            Select Case .subject
                Case "mySubject_01"
                    Call Macro_01
                    
                Case "mySubject_02"
                    Call Macro_02
                    
                Case "mySubject_03"
                    Call Macro_03
            End Select
            
            Set Item = Nothing
        End With
    End If
End Sub