Public m_SearchComplete As Boolean

Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
        m_SearchComplete = True
End Sub

' Оформляет строку в кавычки
Function Quote(strText As String) As String
    Quote = Chr(34) & strText & Chr(34)
End Function

' Рекурсивный поиск всех папок и подпапок и формирование нормального Scope
Function GetFullScope(rootFolder As Folder) As String
    Dim objFld As Folder
    Dim strScope As String
    For Each objFld In rootFolder.Folders
        strScope = strScope & ",'" & objFld.FolderPath & "'"
        If objFld.Folders.Count > 0 Then
          strScope = strScope & "," & GetFullScope(objFld)
        End If
    Next
    GetFullScope = Mid(strScope, 2)
End Function

Public Function StartSearch(myStore As Outlook.store, strPhrase) As Search 'Outlook.Results
    Dim objSearch As Search
    ' Ищем в subject и в textdescription по условию LIKE
    strFind = Quote("urn:schemas:httpmail:subject") & " LIKE '%" & strPhrase & "%' OR _
            " & Quote("urn:schemas:httpmail:textdescription") & " LIKE '%" & strPhrase & "%'"
    Set objSearch = Application.AdvancedSearch(Scope:=GetFullScope(myStore.GetRootFolder), Filter:=strFind, _
                                   SearchSubFolders:=True, Tag:=myStore.FilePath & " - " & strPhrase)
    While m_SearchComplete = False
        DoEvents
    Wend
    m_SearchComplete = False
    Set StartSearch = objSearch
End Function

Sub FindAndReply()
  Dim objOL As Outlook.Application
  Dim ns As Outlook.NameSpace
  Dim stre As Outlook.store
  Dim objRsts As Outlook.results
  Dim objMail As Outlook.MailItem: Dim mailOut As Outlook.MailItem
  Dim dateMail As Date
  Set objOL = Application 'Outlook.Application
  Set ns = objOL.GetNamespace("MAPI")
  dateMail = Now
  ' Перебор идёт всех Store. Если есть Архивная папка, или несколько ящиков, будет искать и там
  For Each stre In ns.Stores ' Application.Session.Stores 
    ' Исключаем папку "Общие папки"
    If stre.DisplayName = "Общие папки" Then GoTo Continue
    ' Тут вызывается сама функция поиска по Store
    Set objRsts = StartSearch(stre, "СТРОКА_ПОИСКА").results 
    ' Дальше идет перебор всех найденных элементов.
    For Each result In objRsts
      If result.Class = olMail Then
        If Not IsEmpty(result.ReceivedTime) Then
          ' Находим самое старое письмо
          If dateMail > result.ReceivedTime Then
            Set objMail = result
            dateMail = result.ReceivedTime
          End If
        End If
      End If
    Next
Continue:
  Next
  If Not objMail Is Nothing Then
    Set mailOut = objMail.Reply
    mailOut.Display
  End If
  Set objMail = Nothing
  Set objRsts = Nothing
  Set ns = Nothing
End Sub