Find e-mail by body and sender - excel

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://learn.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://learn.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