How to get the latest emails and append to the existing file instead of looping through all items using VBA?

[Nidhi24]

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]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