How to reduce running time of below mentioned code

[ThrottleWorks]

Hi,

I am trying to export e-mails in excel worksheet with following code.
There are about 5,000 e-mails in the folder I am trying to access.

Out of these 5,000 only 40-50 are required for further processing.
However, the below mentioned piece takes around 2 minutes to complete.

What I am trying to do.
I have list of 40-50 names in an excel file.

For each name, I need to check if we have received an e-mail containing the name in e-mail body.

For example, first name on the list is “Yamaha”. So I need to check if I have received an e-mail in last 4 days, where e-mail body contains the word “Yamaha”.

I have written below mentioned code for this purpose, but it is very slow.

Can we reduce running time of this code. Can anyone please help me in this.

Sub Chandoo()

 
    Dim appExcel As Excel.Application
 
    Dim rng As Excel.Range
 
    Dim strSheet As String
    Dim strPath As String
 
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
 
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object
 
    Set MacroBook = ThisWorkbook
    Set ScrapSht = MacroBook.Worksheets("Scrap")
    ScrapSht.Cells.Clear
 
    strPath = ThisWorkbook.Path
    strSheet = strPath & strSheet
 
    'Select export folder
    Set nms = Outlook.Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder
 
    'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
            MsgBox "There are no mail messages to export", vbOKOnly, "Error"
            Exit Sub
        ElseIf fld.DefaultItemType <> olMailItem Then
            MsgBox "There are no mail messages to export", vbOKOnly, "Error"
            Exit Sub
        ElseIf fld.Items.Count = 0 Then
            MsgBox "There are no mail messages to export", vbOKOnly, "Error"
            Exit Sub
    End If
 
    'Open and activate Excel workbook.
    MacroBook.Activate
 
    Set appExcel = Excel.Application
    appExcel.Application.Visible = True
 
    MapSht.Range("B1").FormulaR1C1 = "=TODAY()"
    MapSht.Range("B2").FormulaR1C1 = "=WORKDAY(R1C2,-1)"
    MapSht.Range("B3").FormulaR1C1 = "=WORKDAY(R1C2,-2)"
    MapSht.Range("B4").FormulaR1C1 = "=WORKDAY(R1C2,-4)"
 
    MapSht.Range("A2").FormulaR1C1 = "=YEAR(R[-1]C)"
    MapSht.Range("A3").FormulaR1C1 = "=MONTH(R[-2]C)"
    MapSht.Range("A4").FormulaR1C1 = "=DAY(R[-3]C)"
    MapSht.Range("A5").FormulaR1C1 = "=DATE(R[-3]C,R[-2]C,R[-1]C)"
    MapSht.Range("C2").FormulaR1C1 = "=LEFT(R[-1]C,13)=""Key Word""" 'For checking subject line
 
    'Copy field items in mail folder.
    For Each itm In fld.Items
        MapSht.Range("A1").Value = itm.ReceivedTime
        MapSht.Range("C1").Value = itm.Subject
    
        If MapSht.Range("A5").Value > MapSht.Range("B4").Value Then
            If MapSht.Range("A5").Value <= MapSht.Range("B1").Value Then
                'If MapSht.Range("C2").Value = True Then
                    intColumnCounter = 1
                    Set msg = itm
                
                    intRowCounter = intRowCounter + 1
                    Set rng = ScrapSht.Cells(intRowCounter, intColumnCounter)
                
                    'Column A E-Mail Body
                    rng.Value = msg.Body
                    intColumnCounter = intColumnCounter + 1
                    Set rng = ScrapSht.Cells(intRowCounter, intColumnCounter)
                
                    'Column B E-Mail Subject
                    rng.Value = msg.Subject
                    intColumnCounter = intColumnCounter + 1
                    Set rng = ScrapSht.Cells(intRowCounter, intColumnCounter)
                
                    'Column C E-Mail received time
                    rng.Value = msg.ReceivedTime
                    intColumnCounter = intColumnCounter + 1
                    Set rng = ScrapSht.Cells(intRowCounter, intColumnCounter)
                'End If
            End If
        End If
    Next itm
 
    Set appExcel = Nothing
 
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
 
    Set appExcel = Nothing
 
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
End Sub

 

[Debaser]

That code only appears to check dates, not keywords, and I really don't know why you are using formulas for that rather than doing the tests in the code, or filtering the folder to only get items that match the dates you want.

 

[ThrottleWorks]

Hi @Debaser , thanks a lot for the help. This module is part of my macro.
In this module, I export e-mails in excel file which have subject "Chandoo" and have received today or in last 3 business working days.

Once I export these e-mails in excel. I check, if each name from my list is present in exported e-mails.

For example, I have exported 40 e-mails and first word from my list is "Yamaha", then I will search Yamaha in these 40 exported e-mails (40 rows of excel, 1 row for each e-mail).

If search result it true, it means, I have received e-mail in last four days containing Yamaha word in e-mail body.

Good night.

 

[ThrottleWorks]

Resolved. Actually I had faced similar issue couple of moths ago.
Yesterday it just clicked. I replaced For Each loop with For I to n loop.

Thanks a lot.

 

[Debaser]

That's very strange - For Each should be faster than For i when processing collections.

 

[ThrottleWorks]

Hi @Debaser , honestly I do not know, but this is working for me. I will re-check and confirm tomorow.

Good night.