Looping through Outlook emails to update Excel spreadsheet by finding string in email body

Question

I am trying to loop through the Sent folder in Outlook and update my spreadsheet with the "received time" of an email.

My spreadsheet has a column that contain record number. Each email contains one or more record numbers.

If the email body has a matching record then I want to extract the received date and put it in a column.

I believe the issue is with my If statement.

Option Explicit
 
Private Sub CommandButton1_Click()

    On Error GoTo ErrHandler

    ' Set Outlook application object.
    Dim objOutlook As Object

    Set objOutlook = CreateObject("Outlook.Application")
   
    Dim objNSpace As Object     ' Create and Set a NameSpace OBJECT.
    ' The GetNameSpace() method will represent a specified Namespace.
    Set objNSpace = objOutlook.GetNamespace("MAPI")

    Dim myFolder As Object  ' Create a folder object.
    Set myFolder = objNSpace.GetDefaultFolder(olFolderSentMail)

    Dim objItem As Object
    Dim iRows, iCols As Integer
    Dim sFilter As String

    iRows = 2

    Dim MyRange As Range
    Dim cell As Range
    Dim Wb As Workbook
    Dim FiltRange As Range
   
    Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Activate

    'Set MyRange = Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Worksheets("Data").Range(Cells(1, 1).Offset(1, 0), Range("A1").End(xlDown))
    
    ' select the records in column A
    Set MyRange = Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Worksheets("Data").Range(Cells(2, 1), Range("A1").End(xlDown))

    'Debug.Print MyRange.Address
    'only select the filtered records
    Set FiltRange = MyRange.SpecialCells(xlCellTypeVisible)

    'Debug.Print FiltRange.Address

    'create a filter for emails marked as not completed
    sFilter = "[Categories] = 'Not Completed'"

    'Debug.Print sFilter

    ThisWorkbook.Sheets("Sent_Email").Activate

    ' Loop through each item in the folder.

    'Debug.Print myFolder.Items.Restrict(sFilter).Count
    
    'loop through the emails in the sent folder restricted to specific category
    For Each objItem In myFolder.Items.Restrict(sFilter)

        If objItem.Class = olMail Then

            Dim objMail As Outlook.MailItem
            Set objMail = objItem

            'extract data from email
            Cells(iRows, 1) = objMail.Recipients(1)
            Cells(iRows, 2) = objMail.To
            Cells(iRows, 3) = objMail.Subject
            Cells(iRows, 4) = objMail.ReceivedTime
            Cells(iRows, 5) = objMail.Body

            'If MyRange <> "" Then
                
                'loop throug the records on the spreadsheet to find matches
                For Each cell In FiltRange

                    'Debug.Print MyRange.Find(cell.Value)
                    'Debug.Print cell.Value
                    'Debug.Print Cells(iRows, 5)

                    'if the email body contain the matching record or specific string then copy the received time to the row for the matching record
                    If InStr(LCase(Cells(iRows, 5)), cell.Value > 0) And InStr(LCase(Cells(iRows, 5)), LCase("GTPRM")) > 0 Then
    enter code here
                        Debug.Print cell.Value
                        cell(, 35).Value = Cells(iRows, 4).Value

                    End If

                Next cell

            'End If

        End If

        iRows = iRows + 1

    Next

    Set objMail = Nothing

    ' Release.
    Set objOutlook = Nothing
    Set objNSpace = Nothing
    Set myFolder = Nothing

ErrHandler:
    Debug.Print Err.Description

End Sub

Answer 1

As I said in my comment, I cannot explain why your problem statement fails without seeing your data. Instead I will identify issues that will make your code more likely to fail and more difficult to diagnose.

On Error GoTo ErrHandler

I see this statement used by authors who should know better. I am unable to imagine a situation in which this statement would be helpful during development. If there is a problem, I would want execution to stop on the statement causing the problem. I do not want to have to guess which statement caused the problem from the error description. It is more difficult to identify the best approach with operational macros.

There are two types of runtime error: errors you can avoid and errors you cannot avoid. Examples of errors you can avoid include array bound errors and division by zero. You will try to eliminate such errors during testing but there is always the risk of a rare error that you did not allow for. Your choices are to let execution stop at the statement giving the error or jump to an error handler. Neither is an attractive proposition. The code will stop in the middle of something with little chance of a graceful failure. My users have always been such that I can leave detailed instructions about what to record and who to call when execution stops so I have never had to consider an error handler.

An example of an error you cannot avoid is attempting to open a file for which you do not have the necessary access rights. To handle this situation, I recommend this code:

Dim ErrDesc As String
Dim ErrNum As Long
  :
Err.Clear
On Error Result Next
Statement that might fail
ErrNum = Err.Number
ErrDesc = Err.Description
On Error GoTo 0
If ErrNum <> 0 Then
  Code to handle failure
End If  

A variation of this technique is used in this routine:

Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String) As Boolean

  ' Returns True if Worksheet WshtName exists within
  '  * if Wbk Is Nothing the workbook containing the macros
  '  * else workbook Wbk

  Dim WbkLocal As Workbook
  Dim Wsht As Worksheet
  
  If Wbk Is Nothing Then
    Set WbkLocal = ThisWorkbook
  Else
    Set WbkLocal = Wbk
  End If
  
  Err.Clear
  On Error Resume Next
  Set Wsht = WbkLocal.Worksheets(WshtName)
  On Error GoTo 0
  If Wsht Is Nothing Then
    WshtExists = False
  Else
    WshtExists = True
  End If

End Function

This is the routine I use for checking if a worksheet exists within a workbook. I could have used a For-Loop to cycle through the workbook’s worksheets which would have allowed me to avoid using On Error Resume Next. However, the For-Loop approach is a lot slower. I do not check for existence of a worksheet often enough for the time saving to matter but I prefer this code. You might prefer the For-Loop approach.

Placement of variable declarations

If you write Public A As Long outside a subroutine or function, variable A is accessible by any subroutine or function within any module within the workbook.

If you write Dim A As Long outside a subroutine or function, variable A is accessible by any subroutine or function within the same module.

If you write Dim A As Long within a subroutine or function, variable A is accessible by any statement within the same subroutine or function.

Where you place the declaration, determines the scope of the variable. These are the three choices you have with VBA: public, local to module and local to routine. I have heard complaints that a definition of variable scope is difficult to find. There are languages with additional scopes but not for VBA.

You have declared your variable just before first use within your routines. I have read arguments that this is the best approach. I prefer to place all my declarations in alphabetic order at the top of my routine. When I return to a routine six or 12 months after I wrote it, I can find all my declarations and explanations all together at the top. I find this helpful but the choice if yours.

Declaring a variable as an Object

Declaring a variable as an Object is known as late binding. The compiler does not know what type of object will be placed in the variable. The interpreter discovers the type when the variable is set at run time.

The alternative is to reference the Outlook library. Within the VBA Editor, click [Tools] then [References…]. This brings up a list of hundreds of libraries that define variable types and routines that you can make available to your workbook. One such library is “Microsoft Outlook nn.0 Object Library” where nn depends on the version of Office you are using. Tick the box, to the right of this library. You might have already down this since you use Outlook.MailItem in your code.

If I reference the Outlook object library, I can write:

Dim objOutlook As Outlook.Application
Dim objNSpace As Namespace
Dim myFolder As Outlook.Folder

I find it helpful to declare what type of object I will place in a variable. This is known as early binding. You can find discussions on the merits of early versus late binding on the web.

You are correct to write Dim objItem As Object. It is very unlikely that a Sent Folder will contain anything other that MailItems but it is possible. Testing the class of objItem, as you do, is prudent.

Dim iRows, iCols As Integer

With most languages, variables of type Integer and Long are sized according to the word size of the target machine. With VBA, an Integer is 16-bits and a Long is 32 bits. I have read that Integer variables are slower than Long variables on 32 and 64-bit PCs because they need special processing. My attempts at timings have not revealed any differences. The maximum value that can be held in an Integer, is 65,535. A worksheet can have 1,048,576 rows so a variable holding a row number should be Long. I declare all my integer variables as Long because there is no obvious disadvantage and it reduces the chance of an overflow.

Set objOutlook = CreateObject("Outlook.Application")

I open and close Outlook from Excel using this code:

Dim AppOut As Outlook.Application
Dim Created As Boolean
Dim OutNs As Outlook.Namespace

Set AppOut = OutAppGetCreate(Created)
Set OutNs = AppOut.Session

Code accessing Outlook

Call OutAppClose(AppOut, Created) 

The comments within OutAppGetCreate() explain why:

Public Sub OutAppClose(ByRef OutApp As Outlook.Application, ByVal Created As Boolean)

  ' If Created is True, quit the current instance of Outlook.
  
  If Created Then
    OutApp.Quit
  End If
  
  Set OutApp = Nothing

End Sub
Public Function OutAppGetCreate(ByRef Created As Boolean) As Outlook.Application

  ' Return a reference to the Outlook Application.
  ' Set Created to True if the reference is to a new application and to
  ' False if the reference is to an existing application.
  
  ' If Nothing is returned, the routine has been unable to get or create a reference.
  
  ' Only one instance of Outlook can be running.  CreateObject("Outlook.Application")
  ' will return a reference to the existing instance if one is already running or
  ' will start a new instance if one is not running.  The disadvantage of using
  ' CreateObject, is the caller does not know if Outlook was running so does not know
  ' whether or not to quit Outlook when it has finished using Outlook.  By setting
  ' Created, this routine allows the caller to only quit if this is appropriate.

  Set OutAppGetCreate = Nothing
  On Error Resume Next
  Set OutAppGetCreate = GetObject(, "Outlook.Application")
  On Error GoTo 0
  If OutAppGetCreate Is Nothing Then
    On Error Resume Next
    Set OutAppGetCreate = CreateObject("Outlook.Application")
    On Error GoTo 0
    If OutAppGetCreate Is Nothing Then
      Call MsgBox("I am unable to access Outlook", vbOKOnly)
      Exit Function
    End If
    Created = True
  Else
    Created = False
  End If

End Function

Set myFolder = objNSpace.GetDefaultFolder(olFolderSentMail)

I cannot use GetDefaultFolder on my laptop. I have several email addresses and have a store per address plus the default store “Outlook Data.” This is the default Outlook installation as created by the Wizard. Each of these stores have their own Inbox and Sent folders. The empty one in “Outlook Data” is the default returned by GetDefaultFolder.

If you are using a work installation, you may only have one store and the default sent folder is the one you expect. If you are concerned you are getting the wrong sent folder, try Debug.Print myFolder.Parent.Name.

Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Activate ThisWorkbook.Sheets("Sent_Email").Activate

The standard advice is to avoid Activate. The major reason given is that it is a slow method. Certainly, if you are switching between workbooks or worksheets using Activate, you can increase the duration of a macro significantly. This is particularly true if you omit Application.ScreenUpdating = False, as you do, because the screen is repainted every time you update the current worksheet or switch workbook or worksheet. I avoid Activate because it makes it difficult identify the current workbook and worksheet.

If you write:

With Workbooks("RIRQ and RRTNs with LOB Sept 28 2020").Activate
  Set MyRange =.Worksheets("Data") .Range(Cells(2, 1), Range("A1").End(xlDown))
End With
With ThisWorkbook
  With .Sheets("Sent_Email")
      :
    .Cells(iRows, 1) = objMail.Recipients(1)
      :
  End With
End With

You look up to the previous With statement to identify which worksheet or workbook is being accessed. With your approach, you must check for statements that change the current workbook or worksheet as side effects. You must also worry about subroutine changing the current workbook or worksheet.

.Range("A1").End(xlDown)

This is the equivalent of positioning the cursor to cell A1 and then clicking Ctrl+↓. If there is a blank cell in the middle of the column A data, it will stop at the cell above the first blank cell.

The recommended use of End is .Cells(Rows.Count,1).End(xlUp). This stops at the last non-blank cell.

'Debug.Print MyRange.Address
'Debug.Print FiltRange.Address

I make heavy use of Debug.Print and Debug.Assert` during development so I approve. However, I would not have commented out these statement out until I got the code working.

Set FiltRange = MyRange.SpecialCells(xlCellTypeVisible)

What is this statement trying to achieve? Do you really have hidden cells within column A? Are you trying to lose blank cells? Blank cells are visible. It is possible to eliminate blank cells if that is what you want.

If every non-blank cell in MyRange is a value, use:

Set FiltRange = MyRange.SpecialCells(xlCellTypeConstants)

If every non-blank cell in MyRange is a formula, use:

Set FiltRange = MyRange.SpecialCells(xlCellTypeFormulas)

If MyRange is a mixure of values, formulae and blanks use:

Union(MyRange.SpecialCells(xlCellTypeConstants), _
      MyRange.SpecialCells(xlCellTypeFormulas))

If InStr(LCase(Cells(iRows, 5)), cell.Value > 0) And _
   InStr(LCase(Cells(iRows, 5)), LCase("GTPRM")) > 0 Then

I think this would be clearer:

If InStr(LCase(objMail.Body), cell.Value > 0) And _
   InStr(LCase(objMail.Body), ("gtprm")) > 0 Then

Or better still:

LcBody = LCase(objMail.Body)       'Outside loop
   :
If InStr(LcBody, cell.Value > 0) And _
   InStr(LcBody, ("gtprm")) > 0 Then

It was only after this simplification I noticed that the statement should be:

If InStr(LcBody, cell.Value) > 0 And _
   InStr(LcBody, ("gtprm")) > 0 Then

or

If InStr(LCase(Cells(iRows, 5)), cell.Value) > 0 And 
   InStr(LCase(Cells(iRows, 5)), LCase("GTPRM")) > 0 Then 

Answer 2

My improved code is doing what I need.

It takes some time to extract the data from my sent emails folder and write to the spreadsheet.

Private Sub Follow_Up_Update()

    'On Error GoTo ErrHandler

    ' Set Outlook application object.
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")

    Dim objNSpace As Object     ' Create and Set a NameSpace OBJECT.

    ' The GetNameSpace() method will represent a specified Namespace.
    Set objNSpace = objOutlook.GetNamespace("MAPI")

    Dim myFolder As Object  ' Create a folder object.

    Set myFolder = objNSpace.GetDefaultFolder(olFolderSentMail)

    Dim RangeObject As Range
    Dim objItem As Object
    Dim iRows, iCols As Integer
    Dim sFilter As String

    iRows = 2

    Dim MyRange As Range
    Dim cell As Range
    Dim WB As Workbook
    Dim FiltRange As Range
    Dim Lcbody As String
    Dim RIRQWorkbbok As Workbook
    Dim Sup_Number As Range
    Dim objMail As Outlook.MailItem
    Dim Sent_Email As Workbook
    Dim Data As Range
    Dim StringData As String
    Dim CellContent As Range
    Dim Range_SentEmail As Range
    Dim answer As Integer
    Dim sFilter_porfolio As String
    Dim answer_RiRQ As String

    'filter out data
    'Tracker_Filter

    Dim Range_RIRQ As Range

    'Set Sent_Email = ThisWorkbook

    Debug.Print ThisWorkbook.Name

    With ThisWorkbook.Worksheets("Sent_Email")
        .Activate
        Set Range_SentEmail = .Range("E2", Range("E2").End(xlDown))
    End With

    'Debug.Print Sent_Email.Address

    Application.ScreenUpdating = False

    'prompt user to select a file
    answer = MsgBox("Do you want to Open RIRQ/RRTN tracker?", vbYesNoCancel, "Select file")

    If answer = vbYes Then
        FileOpenDialogBox
    Else
        MsgBox "you haven't selected a file !"
        Exit Sub
    End If

    'Debug.Print ActiveWorkbook.Name

    'Tracker_Filter
    'activate the worksheet "Data" on the newly opened workbook

    With ActiveWorkbook.Worksheets("Data")
        .Activate
        'add a header to the column that will contain extracted data from the sent emails folder
        .Cells(1, 36).Value = "Reach outs Date"

        'filter only the RRTN and RIRQs programs
        Tracker_Filter

        'set a reference to the cells on the active sheet
        Set MyRange = .Range(Cells(2, 1), Range("A1").End(xlDown))
    End With

    'set a reference to the visible cells on filtered activesheet
    Set FiltRange = MyRange.SpecialCells(xlCellTypeVisible)

    'Debug.Print FiltRange.Address

    'create a filter based on folder categorie "not Completed" and subject line "Action required: Portfolio Reassessment"

    sFilter = "[Categories] = 'Not Completed' And [Subject] = 'Action required: Portfolio Reassessment'"

    sFilter_porfolio = "[Categories] = 'Not Completed' And [Subject] = 'Urgent: SEMS Portfolio Reassessment: Phase 1'"

    'Debug.Print sFilter

    'loop through the sent emails folder and write the data to the sheet called "Sent_Email"
    If ThisWorkbook.Sheets("Sent_Email").Cells(2, 1) = "" Then

        For Each objItem In myFolder.Items.Restrict(sFilter)

            If objItem.Class = olMail Then

                Set objMail = objItem
                With ThisWorkbook.Sheets("Sent_Email")
                    .Cells(iRows, 1) = objMail.Recipients(1)
                    '.Cells(iRows, 2) = objMail.To
                    .Cells(iRows, 3) = objMail.Subject
                    .Cells(iRows, 4) = objMail.ReceivedTime
                    .Cells(iRows, 5) = objMail.Body
                    .Cells(iRows, 6) = ResolveDisplayNameToSMTP(objMail.Recipients(1))

                    'End With
                End With
            End If

            iRows = iRows + 1

        Next objItem

    End If

    'ask user if they want to extract dates when emails were seent
    answer_RiRQ = MsgBox("Do you want to update RRTN/RRIQs reach outs dates?", vbYesNoCancel, "RRTN/RIRQ")

    If ThisWorkbook.Sheets("RIRQ-RRTN_emails").Cells(2, 1) = "" Then

        If answer = vbYes Then

            iRows = 2

            For Each objItem In myFolder.Items.Restrict(sFilter_porfolio)

                If objItem.Class = olMail Then

                    Set objMail = objItem

                    With ThisWorkbook.Sheets("RIRQ-RRTN_emails")
                        .Cells(iRows, 1) = objMail.Recipients(1)
                        '.Cells(iRows, 2) = objMail.To
                        .Cells(iRows, 3) = objMail.Subject
                        .Cells(iRows, 4) = objMail.ReceivedTime
                        .Cells(iRows, 5) = objMail.Body
                        .Cells(iRows, 6) = ResolveDisplayNameToSMTP(objMail.Recipients(1))

                        'End With
                     End With
                 End If

                 iRows = iRows + 1

            Next objItem

        Else

             MsgBox "script will continue to run!"

        End If

    End If

    'activate the worksheet where the data was written based on the filter : sFilter_porfolio

    With ThisWorkbook.Worksheets("RIRQ-RRTN_emails")
        .Activate

        'set a reference to the cells that contain data extracted based on filter called sFilter_porfolio

        Set Range_RIRQ = .Range("E2", Range("E2").End(xlDown))

    End With    

    For Each cell In FiltRange

        cell.Offset(, 12).Value = Trim(cell.Offset(, 12).Value)

        'write to the main sheet based on the condition
        For Each Data In Range_RIRQ
            If InStr(Data.Value, cell.Value) > 0 Then
                cell.Offset(, 36).Value = "Esccalation note sent on " & Data.Offset(, -1).Value
                'Debug.Print cell.Offset(, 35).Value
                'Debug.Print cell.Offset(, 35)
            End If
        Next Data

        'Next cell

        Application.ActiveSheet.Columns("AK:AK").AutoFit

        'End If

        For Each Data In Range_SentEmail
            'write to the main sheet based on the condition
            If InStr(Data.Value, cell.Value) > 0 Then
                cell.Offset(, 35).Value = "first communication sent on " & Data.Offset(, -1).Value          
            End If
        Next Data

    Next cell

    Application.ActiveSheet.Columns("AJ:AJ").AutoFit

    Application.ScreenUpdating = True

    Set objMail = Nothing

    ' Release.
    Set objOutlook = Nothing
    Set objNSpace = Nothing
    Set myFolder = Nothing

'ErrHandler:

    'Debug.Print Err.Description

End Sub