Extract details from Outlook emails using Excel VBA based on word in subject and date

Question

I want to extract Outlook email data using Excel VBA according to specific words in subject of email.

The subject of emails changes but part of the subject is the same on all the emails.

e.g. My email Subject is "Prod - Work Daily Alert for user Steve Johnson (1234567)"

The static part of the subject is: "Prod - Work Daily Alert for user".

The dynamic part of the subject is: "Steve Johnson (1234567)".

I want to extract data from email according to the static part.

I tried to use below VBA code from StackOverflow with some modification. It does not satisfy "If" condition so it does not extract anything from email.

If I remove

If InStr(olMail.Subject, "Prod - Work Daily Alert for user") > 0 _
  And InStr(olMail.ReceivedTime, x) > 0 Then

then it extracts data from all emails in the inbox.

Sub ExtractEmailContent()

    Dim olApp As Outlook.Application, olNs As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
    Dim eFolder As Outlook.Folder 
    Dim i As Long
    Dim x As Date, ws As Worksheet 
    Dim lRow As Long 

    Set ws = ActiveSheet

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    x = Date

    For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders

        Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
        
        For i = olFolder.Items.Count To 1 Step -1
            If TypeOf olFolder.Items(i) Is MailItem Then
                Set olMail = olFolder.Items(i)
                
                If InStr(olMail.Subject, "Prod - Work Daily Alert for user") > 0 _
                  And InStr(olMail.ReceivedTime, x) > 0 Then

                    With ws
                        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
                        .Range("A" & lRow).Offset(1, 0).Value = olMail.Subject
                        .Range("A" & lRow).Offset(1, 1).Value = 
                        olMail.ReceivedTime
                        .Range("A" & lRow).Offset(1, 2).Value = 
                        olMail.SenderName
                        .Range("A" & lRow).Offset(1, 3).Value = olMail.CC
                        .Range("A" & lRow).Offset(1, 4).Value = olMail.Body
                    End With
                End If
            End If
        Next i
        
        'forward_Email ()
        Set olFolder = Nothing
    Next eFolder
End Sub

[Look here](https://stackoverflow.com/questions/11876549/how-to-copy-outlook-mail-message-into-excel-using-vba-or-macros) — TourEiffel, Aug 27 '19 at 13:39
Why would you use `Instr` on a date? Delete the `And InStr(olMail.ReceivedTime, x) > 0` part. — user3819867, Aug 27 '19 at 13:47
If I delete Instr part it extract data from all the from inboxes which is huge in number. I just want to extract data from email which matches static subject part of email. — Vishal, Aug 27 '19 at 14:05

score 0 · Answer 1 · answered Nov 14 '19 at 15:23

The And InStr(olMail.ReceivedTime, x) > 0 is odd.

This may be a better method of checking the date.

Option Explicit

Sub ExtractEmailContent_Inefficiently()

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olFolder As Outlook.folder
    Dim olMail As Outlook.MailItem

    Dim i As Long

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")

    Set olFolder = olNs.GetDefaultFolder(olFolderInbox)

    Debug.Print "olFolder.Items.Count: " & olFolder.Items.Count

    For i = olFolder.Items.Count To 1 Step -1

        If TypeOf olFolder.Items(i) Is MailItem Then

            Set olMail = olFolder.Items(i)

            If InStr(olMail.Subject, "Prod - Work Daily Alert for user") > 0 Then

                If olMail.ReceivedTime >= Date Then
                    Debug.Print i & " - olMail.ReceivedTime: " & olMail.ReceivedTime
                Else
                    Debug.Print i & " - processing every item is inefficient."
                End If

            End If

        End If

    Next i

End Sub

You could cut down on the number of items processed with Restrict.

Sub ExtractEmailContent_Restrict()

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.NameSpace
    Dim olFolder As Outlook.folder
    Dim olMail As Outlook.MailItem

    Dim i As Long

    Dim strFilter As String
    Dim olResults As Outlook.Items

    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")

    Set olFolder = olNs.GetDefaultFolder(olFolderInbox)

    ' Apply formatting to Date
    strFilter = "[ReceivedTime]>'" & Format(Date, "DDDDD HH:NN") & "'"
    Debug.Print "strFilter .....: " & strFilter

    Set olResults = olFolder.Items.Restrict(strFilter)
    Debug.Print "olResults.Count: " & olResults.Count

    For i = olResults.Count To 1 Step -1

        If TypeOf olResults(i) Is MailItem Then

            Set olMail = olResults(i)

            If InStr(olMail.Subject, "Prod - Work Daily Alert for user") > 0 Then
                Debug.Print i & " - olMail.ReceivedTime: " & olMail.ReceivedTime
            End If

        End If

    Next i

End Sub

Extract details from Outlook emails using Excel VBA based on word in subject and date

1 Answers1