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.
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: