I have a code that loops through all the outlook emails under a subfolder and extract the body of the email based on the subject. How do I modify the code to only append the data extracted from emails in the existing file instead of looping through all the emails and overwriting again & again? Code takes a lot of time to loop through all emails as there are thousands of them. How do I just get the recent data, let's say I want to run the code everyday to get prior day's email data? How do I modify my below code? This is what I have for now.
VBA Code:
Option Explicit
Sub FinalMacro()
Application.DisplayAlerts = False
Dim iCounter As Integer
'iCounter = 1
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.Clear
' point to the desired email
Const strMail As String = "[EMAIL]emailaddress@outlook.com[/EMAIL]"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
'Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object
With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With
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(strMail).Folders("inbox").Folders("Other mails")
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" Then
' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With
Dim t As Long, r As Long, c As Long
Dim eRow As Long
For t = 0 To tables.Length - 1
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For r = 0 To (tables(t).Rows.Length - 1)
For c = 0 To (tables(t).Rows(r).Cells.Length - 1)
Range("A" & eRow).Offset(r, c).Value = tables(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) = "Date & Time of Receipt:" & " " & oItem.ReceivedTime
Cells(eRow, 1).Interior.Color = vbRed
Cells(eRow, 1).Font.Color = vbWhite
Cells(eRow, 1).Columns.AutoFit
Set oApp = Nothing
Set oMapi = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.Save '"C:\Users\Desktop\Trial_1.xlsm"
End If
Next oItem
Application.DisplayAlerts = True
End Sub
