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.
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]firstname.lastname@example.org[/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