按正文和发件人查找电子邮件

Question

我一直在尝试创建代码，该代码将查找与正文+发件人匹配的电子邮件。每天，我必须检查大约300/400封电子邮件是否已经发送，所以最好的方法是使其自动化。

困难的是，我需要遍历4500封以上的电子邮件，这就是我的方式有误的原因-需要很多时间

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

Thjis代码运行所有电子邮件，并检查在正文中和正确的发件人中是否包含正确数目的电子邮件，但是对于4500封以上的电子邮件来说，一次一件地花费大量时间。 / p>

任何想法如何解决？也许通过在VBA中添加一些引用？