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

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

CodePudding user response：

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