Find e-mail by body and sender

Question

I am trying find e-mail that matches body text and sender.

Each day I check if 300/400 emails were already sent.

I need to iterate through more than 4500 emails.

Sub Check()
    Application.Calculation = xlManual
    Dim OutApp As Object
    Dim OutNameSpace As Object
    Dim OutFolder As Object
    Dim OutItms As Object
    Dim OutMail As Object

    Dim Last As Long
    Last = ThisWorkbook.Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row

    Set OutApp = CreateObject("Outlook.Application")
    Set OutNameSpace = OutApp.GetNamespace("MAPI")
    Set OutFolder = OutNameSpace.GetDefaultFolder(6).Folders("Inne")
    Set OutItms = OutFolder.Items

    Set numbers = ThisWorkbook().Sheets(2).Range(Cells(2, 2), Cells(Last, 2))
    Dim numer As Range
    For Each number In numbers
        Z = 1
        If numer = "" Then GoTo nastepny
        For Each OutMail In OutFolder.Items
            If InStr(1, OutMail.Body, number, vbTextCompare) <> 0 Then
                If InStr(1, OutMail.Sender, "Sender Name", vbTextCompare) <> 0 Then
                    number.Offset(0, 7) = "Yes"
                    GoTo nastepny
                End If
            Else
                number.Offset(0, 7) = "No"
            End If
nastepny:
    Next OutMail, number

    Application.Calculation = xlAutomatic

End Sub

This code runs through all e-mails and checks if there is e-mail with correct number in body and correct sender. For more then 4500 e-mails it takes a lot of time to do it one by one.

Answer 1

With Restrict determine whether any item contains applicable text.
https://docs.microsoft.com/en-us/office/client-developer/outlook/pia/how-to-search-for-a-phrase-in-the-body-of-items-in-a-folder

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant


Sub Check()

    Application.Calculation = xlManual
    
    ' Late binding.
    ' Reference to Microsoft Outlook XX.X Object Library not required.
    Dim OutApp As Object
    Dim OutNameSpace As Object
    Dim OutFolder As Object
    Dim OutItms As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutNameSpace = OutApp.GetNamespace("MAPI")
    
    ' Assumptions:
    ' 1 - Inne is the sender
    ' 2 - Applicable items from Inne in subfolder Inne
        
    Set OutFolder = OutNameSpace.GetDefaultFolder(6).Folders("Inne")
    Set OutItms = OutFolder.Items
Debug.Print " OutItms.Count.....: " & OutItms.Count
    
    Dim wB As Workbook
    Set wB = ThisWorkbook
    
    Dim wS As Worksheet
    Set wS = wB.Worksheets(2)
    
    Dim Last As Long
    Dim numbers As Range
    
    With wS
        'Entries in column 2
        Last = .Cells(.Rows.Count, 2).End(xlUp).Row
        Set numbers = .Range(.Cells(2, 2), .Cells(Last, 2))
    End With
    
    Dim numBer As Range
    For Each numBer In numbers

        If numBer <> "" Then
            
            Dim strFilter As String
            ' https://docs.microsoft.com/en-us/office/client-developer/outlook/pia/how-to-search-for-a-phrase-in-the-body-of-items-in-a-folder
            strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:textdescription" & Chr(34) & " like '%" & numBer & "%'"
Debug.Print strFilter
            
            Dim numBerResults As Object
            Set numBerResults = OutFolder.Items.Restrict(strFilter)
Debug.Print " numBerResults.Count.....: " & numBerResults.Count
    
            If numBerResults.Count > 0 Then
                numBer.Offset(0, 7) = "Yes"
            Else
                numBer.Offset(0, 7) = "No"
            End If
                
        End If
        
    Next numBer
    
    Application.Calculation = xlAutomatic

Debug.Print "Done."

End Sub