Option Explicit

Public Sub saveAttachtoDisk() 'объявляем процедуру записи вложений писем в папку на компьютере.
  Const myFolder As String = "C:\Test\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки info@test.ru совпадает с адресом отправителя
  
  Dim myItem As Outlook.MailItem
  Dim oFolder As Outlook.Folder
  Dim Account As Outlook.NameSpace
  
  Dim a As Integer ' вспомогательная переменная для разных нужд
  Dim i As Integer ' вспомогательная переменная для разных нужд
  Dim f As Integer 'вспомогательная переменная для разных нужд
  
  Dim SenderMail As String 'переменная для обозначения имени отправителя из писем которого мы будем вытаскиваеть вложения и записывать из в папку на компьютере
  Dim Savefolder As String ' переменная для записи пути к папке , куда скидываем наши вложения из аутлука
  Dim AccountName As String ' переменная для записи имени Учетной записи в аутлуке, где мы ищем наши письма с вложениями
  
   
  SenderMail = "info@test.ru" ' от этого отправителя нужно сохранять файлы
  AccountName = "name@name.ru" ' в этой учетной записи будем просматривать папки
  
  If Dir(myFolder & SenderMail, vbDirectory) = "" Then  ' проверяем , если на компе каталог
    MkDir myFolder & SenderMail  ' и если папки info@test.ru нет, то создаем её в каталоге C:\Test\
  End If
  Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере  ( C:\Test\ info@test.ru )
  
  'Debug.Print savefolder
  
  Set Account = Application.GetNamespace("MAPI") ' получаем доступ к учетным записям в аутлук
  'Set inboxFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' получаем коллекцию писем в папке Входящие (включая подпапки) в аутлук
  
  For f = 1 To Account.Folders.Count  ' пробегаем циклом по всем учетным записям в аутлуке
  If Account.Folders(f).Name = AccountName Then  ' если имя учетной записи равно AccountName , то
    Set oFolder = Account.Folders(f).Folders(11) ' получаем коллекцию писем в учетной записи AccountName в папке номер 11
  
    
    For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
      If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
      Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
          If myItem.SenderEmailAddress = SenderMail Then ' если в этом письме адрес отправителя равен SenderMail , то
     
                    For a = 1 To myItem.Attachments.Count
                      If myItem.Attachments.Item(a).FileName Like "*.xl*" Then
                            myItem.Attachments.Item(a).SaveAsFile Savefolder
                      End If
                    Next
          
          End If
       End If
    Next i
  End If
  Next f

  
End Sub

Savefolder = myFolder & SenderMail ' Это папка а не путь к файлу
myItem.Attachments.Item(a).SaveAsFile Savefolder
' Так должно быть
myItem.Attachments.Item(a).SaveAsFile Savefolder & "/file.xlsx"

myItem.Attachments.Item(a).SaveAsFile Savefolder & "/" & myItem.Attachments.Item(a).FileName

    For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
     If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
        Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
         CopyRule myItem  '' Эта вставка
     End If
    Next i

For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
    If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
        Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
        RuleSave myItem  '' Эта вставка
    End If
    Next i

Option Explicit

Public Sub saveAttachtoDisk( myItem as MailItem)  'объявляем процедуру записи вложений писем в папку на компьютере.
  Const myFolder As String = "D:\YandexDisk\YandexDisk\" ' в константу MyFolder пишем путь куда сохранять вложения из писем,при этом название конечной папки info@realtycalendar.ru совпадает с адресом отправителя
  
  Dim myItem As Outlook.MailItem
  Dim oFolder As Outlook.folder
  Dim Account As Outlook.NameSpace
  
  Dim a As Integer ' вспомогательная переменная для разных нужд
  Dim i As Integer ' вспомогательная переменная для разных нужд
  Dim f As Integer 'вспомогательная переменная для разных нужд
  
  Dim SenderMail As String 'переменная для обозначения имени отправителя из писем которого мы будем вытаскиваеть вложения и записывать из в папку на компьютере
  Dim Savefolder As String ' переменная для записи пути к папке , куда скидываем наши вложения из аутлука
  Dim AccountName As String ' переменная для записи имени Учетной записи в аутлуке, где мы ищем наши письма с вложениями
  
  
  SenderMail = "info@realtycalendar.ru" ' от этого отправителя нужно сохранять файлы в папке D:\YandexDisk\YandexDisk\info@realtycalendar.ru
  AccountName = "sport11b@ya.ru" ' в этой учетной записи будем просматривать папки
 
  
  If Dir(myFolder & SenderMail, vbDirectory) = "" Then  ' проверяем , если на компе в каталоге D:\YandexDisk\YandexDisk\ папка info@realtycalendar.ru
    MkDir myFolder & SenderMail  ' и если папки info@realtycalendar.ru нет, то создаем её
  End If
  Savefolder = myFolder & SenderMail ' записываем в переменную путь к нашей целевой папке на компьютере  ( D:\YandexDisk\YandexDisk\ папка info@realtycalendar.ru )
  
  'Debug.Print savefolder
  
  Set Account = Application.GetNamespace("MAPI") ' получаем доступ к учетным записям в аутлук
  'Set inboxFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' получаем коллекцию писем в папке Входящие (включая подпапки) в аутлук
  
  For f = 1 To Account.Folders.Count  ' пробегаем циклом по всем учетным записям в аутлуке
  If Account.Folders(f).Name = AccountName Then  ' если имя учетной записи равно AccountName , то
    Set oFolder = Account.Folders(f).Folders(11) ' получаем коллекцию писем в учетной записи AccountName в папке номер 11
  
    
    For i = 1 To oFolder.Items.Count  ' пробегаем циклом по каждому элементу в папке oFolder
      If oFolder.Items(i).Class = olMail Then   ' если элемент в папке oFolder - это письмо, то
      Set myItem = oFolder.Items.Item(i) ' присваиваем переменной myItem это письмо
      
          If myItem.SenderEmailAddress = SenderMail Then ' если в этом письме адрес отправителя равен SenderMail , то

                    For a = 1 To myItem.Attachments.Count
                      If myItem.Attachments.Item(a).fileName Like "*.xl*" Then
                            myItem.Attachments.Item(a).SaveAsFile Savefolder & "/" & myItem.Attachments.Item(a).fileName
                      End If
                    Next

          End If
       End If
    Next i
  End If
  Next f

  
End Sub

'Процедура показывает все учетные записи и все папки в них
Sub Учетки_и_папки()

   Dim x, xx
   Dim oNspace As Outlook.NameSpace
   Set oNspace = Application.GetNamespace("MAPI")
    For x = 1 To oNspace.Folders.Count
        Debug.Print oNspace.Folders(x).Name & " ==> " & x
        For xx = 1 To oNspace.Folders(x).Folders.Count
            Debug.Print vbTab & oNspace.Folders(x).Folders(xx).Name & " ==> " & xx
        Next
        Debug.Print "============== "
    Next
End Sub