How to extract email data based on Date & subject using VBA? - excel

Question

I have a code that is extracting the emails based on subject. But I wanted to extract the mails based on date as well. So it should be the intersection of Date & subject, only if both condition satisfies I should get the extracted data. Just with the subject condition the code works fine, but when I am adding the date condition, it's not picking up correctly.
For eg: I want to extract yesterday's email with subject line as "Volume data". what am I doing wrong in the code? Can someone help please?
Option Explicit
Sub FinalMacro()
Application.DisplayAlerts = False
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.Clear
' point to the desired email
Const strMail As String = "emailaddress"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oItem As Object
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("Others")
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" & oItem.ReceivedTime = Date Then
'If oItem.ReceivedTime = Date Then
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
'End If
End If
Next oItem
wkb.Save
Application.DisplayAlerts = True
End Sub

Answer 1

Please, test the next adapted code:
Sub FinalMacro()
Dim wkb As Workbook: Set wkb = ThisWorkbook
'Sheets("Sheet1").cells.Clear 'uncomment if you need to start from the first row...
' point to the desired email
Const strMail As String = "emailaddress"
Dim oApp As Outlook.Application, oMapi As Outlook.MAPIFolder, oItem As Outlook.MailItem
Dim destCell As Range, i As Long
With ActiveSheet
Set destCell = .cells(rows.count, "A").End(xlUp) 'last cell where from to extract the last date
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
Dim HTMLdoc As MSHTML.HTMLDocument, tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Dim t As Long, r As Long, c As Long, eRow As Long
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox") 'Folders("Others")
'the necessary elements to extract only the necessary mails:_______________________________________________
Dim startDate As String, endDate As String, flt As String
startDate = CStr(Date) & " " & "00:00" 'Date can be replaced with any string Date
endDate = CStr(Date + 1) & " " & "00:00" 'the same, it should be the previous Date +1
flt = "[Subject] = 'Volume data' and [ReceivedTime] >= '" & startDate & "' and [ReceivedTime] < '" & endDate & "'"
Dim myItems As Outlook.items
Set myItems = oMapi.items.Restrict(flt) '____________________________________________________________
Application.DisplayAlerts = False
For Each oItem In myItems
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.body.innerHTML = oItem.HtmlBody
Set tables = .getElementsByTagName("table")
End With
For t = 0 To tables.Length - 1
eRow = ActiveSheet.cells(rows.count, 1).End(xlUp).row + 1
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 = ActiveSheet.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
Next oItem
wkb.Save
Application.DisplayAlerts = True
End Sub
endDate is necessary only if you choose for filtering a Date in the past.
Not tested, of course, I do not have the necessary data, but this should be the idea. I tested only the filtering part and it worked as needed.
Edited:
Now, there are some variants in order to build the necessary start/end date, in order to fulfill different cases:
To process mails received from 12th of October 2021 till the end of the month, use the next definitions:
startDate = CStr(DateSerial(2021, 10, 12)) & " " & "00:00"
endDate = CStr(DateSerial(2021, 11, 1)) & " " & "00:00"
To process mails received today after 12 o'clock, use the next definitions:
startDate = CStr(Date) & " " & "12:00"
endDate = CStr(Date + 1) & " " & "00:00"
In such a case the filter (flt) string definition may miss the endDate part, which does not matter too much in such a context...
Since your code records oItem.ReceivedTime as cells(eRow, 1) = "Date & Time of Receipt:" & " " & oItem.ReceivedTime, the last recorded time can be extracted and process all mails received after that specific time:
'1. comment the next existing code line:
'Sheets("Sheet1").Cells.Clear
`2. declare the next new (necessary) variables:
Dim destCell As Range, lastOne As String, arrD, arrS
Set DestCell = ActiveSheet.cells(rows.count, "A").End(xlUp)
arrD = Split(destCell.value, " "): arrS = Split(arrD(6), ":")
lastOne = arrD(5) & " " & arrS(0) & ":" & arrS(1)
`3. Change the filter string:
flt = "[Subject] = 'Volume data' and [ReceivedTime] > '" & lastOne & "'"
If something not clear enough, do not hesitate to ask for clarifications. But after you tried understanding how it works and deduce where a mistake could appear and why...
Our mission here is not to supply free code samples, it is to make as many as possible users LEARN...