Generated reply email is catching the oldest email that includes the subject text

Question

The code below will generate a reply email based on the text that is input in the cell Worksheets("Checklist Form").Range("B5"))

This reply email has all the recipients, a customized body, subject and everything works perfectly. EXCEPT I realized through testing that it will grab the oldest email with the text subject or the oldest email that contains that text in it's subject. The thing is, the code seems to copy the recipients from the oldest email of the oldest thread that is in your inbox but then replies to the most recent email in that same thread.

For example if the worksheet(Checklist Form B5) contains the phrase "Kawhi Leonard" the reply email generated will reply to the oldest email thread, but the newest email it seems in that thread. What's weird is it will catch the recipients of the oldest email of the oldest thread in your inbox that contains that subject.

This is a problem since I get many emails with some of the same key words or subjects. Is there a solution to have the code grab the most recent text in a subject of an email. Or a better solution would have a choice of catching the most recent or another one. Or also grab the email with the exact subject not the oldest one that contains the text in it's subject.

Sub Display()

    Dim olApp As Outlook.Application
    Dim olNs As Namespace
    Dim Fldr As MAPIFolder
    Dim olMail As Variant
    Dim i As Integer
    Dim IsExecuted As Boolean

    Signature = Environ("appdata") & "\Microsoft\Signatures\"

    If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
    Else
        Signature = ""
    End If

    Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll

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

    IsExecuted = False

    For Each olMail In Fldr.Items
        If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B5")) <> 0 Then
            If Not IsExecuted Then

                With olMail.ReplyAll
                    .HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & _
                    "Hi    Everyone," & "<p style='font-family:calibri;font-size:14.5'>" & _
                    Worksheets("Checklist Form").Range("B4") & "Regards," & "</p><br>" & _
                    Signature & .HTMLBody

                    .Display
                End With

                IsExecuted = True

            End If
        End If
    Next olMail

End Sub

Answer 1

Firstly, never loop through all items in a folder - use Items.Find/FindNext or Items.Restrict . In your particular case, call Items.Sort , then Items.Find - you only need a ingle item.

Secondly, you need to sort the collection first - call Items.Sort on ReceivedTime .

Thirdly, you are invoking Worksheets("Checklist Form").Range("B5") on each step of the loop. This is extremely inefficient.

Off the top of my head:

set items = Fldr.Items
items.Sort "ReceivedTime", true
strSubject = Worksheets("Checklist Form").Range("B5")
set olMail = items.Find(" @SQL=Subject LIKE '" & strSubject & "'")