Cells(1, 1) = "Data"
        Cells(1, 2) = "To"
        Cells(1, 3) = "Subject"
        Cells(1, 4) = "Status"

            ReDim aRec(1 To itm.Recipients.Count)
            For ir = 1 To itm.Recipients.Count
                aRec(ir) = itm.Recipients(ir) & "(" & itm.Recipients(ir).Address & ")"
            Next
            aRes(r, 2) = Join(aRec, "; ")

Workbooks(a).Close 0

Sub auto()
Dim r, p, a As String
 
r = "Путь к файлу" \\ изменил из за конфиденциальности
a = Dir(r)
GetObject (r)
ThisWorkbook.Worksheets(1).Range("D31").Resize(3).Value = Workbooks(a).Worksheets("октябрь").Range("B4").Resize(3).Value
ThisWorkbook.Worksheets(1).Range("I31").Resize(3).Value = Workbooks(a).Worksheets("октябрь").Range("C4").Resize(3).Value
Workbooks(a).Close 0 
End Sub

Public Sub Test()
    Dim myOlApp As Object 'New Outlook.Application
    Dim objNamespace As Object 'Outlook.Namespace
    Dim objFolder As Object 'Outlook.MAPIFolder
    Dim filteredItems As Object 'Outlook.Items
    Dim itm As Object
    Dim strFilter As String
    Dim r As Long, ir As Long
    Dim aRec, aRes
  
    Set myOlApp = CreateObject("Outlook.Application")
    Set objNamespace = myOlApp.GetNamespace("MAPI")
    Set objFolder = objNamespace.Folders("vasya.pupkin@hp.com").Folders("Sent Items")
  
    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & Chr(34) & " >= '" & Format(DateSerial(2020, 9, 1), "dd/MM/YYYY") & "' AND " & _
                          Chr(34) & "urn:schemas:httpmail:datereceived" & Chr(34) & " <= '" & Format(DateSerial(2020, 9, 24), "dd/MM/YYYY") & "'"
  
    Set filteredItems = objFolder.Items.Restrict(strFilter)
    If filteredItems.Count = 0 Then
        Debug.Print "Не найдено писем по заданным условиям"
    Else
        r = 1
        ReDim aRes(1 To filteredItems.Count, 1 To 4)
        For Each itm In filteredItems
            aRes(r, 1) = itm.CreationTime
            ReDim aRec(1 To itm.Recipients.Count)
            For ir = 1 To itm.Recipients.Count
                aRec(ir) = itm.Recipients(ir)
            Next
            aRes(r, 2) = Join(aRec, "; ")
            aRes(r, 3) = itm.Subject
            aRes(r, 4) = itm.Categories
            r = r + 1
        Next
        Cells(2, 1).Resize(filteredItems.Count, 4).Value = aRes
    End If
End Sub

.HTMLBody = .HTMLBody & "<br>" & strbody & "<br><br>" _
            & "<img src='cid:123.jpg'" & "width=width height=heigth><br><br>"

Dim rWDrr As Object, v
    Set rWDrr = objWrdDoc.Range
    v = rWDrr.Find.Execute("Яблоко", , , , , , True, 0)
    If v Then
        objWrdDoc.SaveAs2 Filename:= _
            "C:\Users\KLC Team\Desktop\6_TESTs\Название1.docx"
    End If

=СУММПРОИЗВ(([Книга1]Лист1!$A$1:$A$3=A1)*([Книга1]Лист1!$B$1:$D$3))

Range("A" & i).Value = Range("A" & i)