Private Sub Application_NewMail()
 
Dim myFolder As Outlook.MAPIFolder
Dim mi
DestFolder = "D:\путь к папке\"
Set myFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
 
For Each mi In myFolder.Items.Restrict("[Unread]=TRUE")
    If mi.Class = olMail Then
        If mi.Attachments.Count > 0 Then
            For j = 1 To mi.Attachments.Count
                If InStr(1, mi.Attachments.Item(j).FileName, "Имя файла", vbTextCompare) > 0 And _
                InStr(1, mi.Attachments.Item(j).FileName, Date, vbTextCompare) > 0 Then
                    If Len(Dir(DestFolder & "файлы " & Date, vbDirectory)) = 0 Then
                        MkDir DestFolder & "файлы " & Date
                    End If
                    Debug.Print (DestFolder & mi.Attachments.Item(j).DisplayName)
                    mi.Attachments.Item(j).SaveAsFile DestFolder & "файлы " & Date & "\" & mi.Attachments.Item(j).FileName
                    mi.UnRead = False
                End If
            Next j
        End If
    End If
Next mi
End Sub

Private Sub Application_NewMail()

Dim myFolder As Outlook.MAPIFolder
Dim mi As MailItem
DestFolder = "D:\путь к папке\"
Set myFolder = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

For Each mi In myFolder.Items.Restrict("[Unread]=TRUE")
    If mi.Class = olMail Then
        If mi.Attachments.Count > 0 Then
            For j = 1 To mi.Attachments.Count
                If InStr(1, mi.Attachments.Item(j).FileName, "Имя файла", vbTextCompare) > 0 And _
                InStr(1, mi.Attachments.Item(j).FileName, Date, vbTextCompare) > 0 Then
                    If Len(Dir(DestFolder & "файлы " & Date, vbDirectory)) = 0 Then
                        MkDir DestFolder & "файлы " & Date
                    End If
                    Debug.Print (DestFolder & mi.Attachments.Item(j).DisplayName)
                    mi.Attachments.Item(j).SaveAsFile DestFolder & "файлы " & Date & "\" & mi.Attachments.Item(j).FileName
                    mi.UnRead = False
                End If
            Next j
        End If
    End If
Next mi

End Sub

Public Sub macroinOutlook()
    Dim olookApp As Object
    Set olookApp = CreateObject("Outlook.Application")
    
    olookApp.SendMail
    
    Set olookApp = Nothing
End Sub

Sub Mail_Notification()
    Dim objOutlookApp As Object, objMail As Object
    Dim sToHiddenCopy As String, sSubject As String
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = "здесь почта сотрудника полученная из массива по его имени, передается через глобальную переменную."
    sToCopy = "здесь почта его руководителя"
    sToHiddenCopy = "здесь моя почта"
    sSubject = "Уведомление о сроках"
    With objMail
        .to = sTo
        .CC = sToCopy
        .BCC = sToHiddenCopy
        .Subject = sSubject
        .Body = sBody
        If Dir(sAttachment, 16) <> "" Then
            .Attachments.Add sAttachment
        End If
        .Send
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

ThisWorkbook.Worksheets(1).Range(Cells(2, 1), Cells(2, 10)).ClearContents

For Each wsBaseSheet In wbAct.Worksheets 'цикл по всем листам в открытой книге
            sSheetNameBase = wsBaseSheet.Name ' присваиваем строковой переменной имя листа из открытой книги
            If sSheetNameBase = sSheetName Then 'сравниваем имя листа в книге и имя листа в массиве
                For b = 1 To arrCol(a) 
                    lRow1 = wbAct.wsBaseSheet.Cells(Rows.Count, b).End(xlUp).Row 

For Each wsBaseSheet In wbAct.Worksheets 'цикл по всем листам в открытой книге
            sSheetNameBase = wsBaseSheet.Name ' присваиваем строковой переменной имя листа из открытой книги
            Set wsWsheet = wbAct.Worksheets(" & sSheetNameBase & ") 
            If sSheetNameBase = sSheetName Then 'сравниваем имя листа в книге и имя листа в массиве
                For b = 1 To arrCol(a) 
                    lRow1 = wbAct.wsWsheet .Cells(Rows.Count, b).End(xlUp).Row 

Public Sub UserForm_Initialize()
Dim dic As Object, cell As Range
Dim arrList(), ikey
Dim lLastrow As Long
TextBox1.Value = Format(Date, "dd.mm.yyyy")
TextBox2.Value = Format(Date, "dd.mm.yyyy")
TextBox3.Value = Format("08:00", "hh:mm")
TextBox4.Value = Format("20:00", "hh:mm")
arrRow = Array(2, 3, 11)
For Each e In arrRow
lLastrow = ActiveSheet.Cells(Rows.Count, e).End(xlUp).Row
Set rList = ActiveSheet.Range(Cells(3, e), Cells(lLastrow, e))
Set dic = CreateObject("Scripting.Dictionary")
    For Each cell In rList
        If cell.Value <> "" Then
            If dic.exists(CStr(cell.Value)) Then dic.Item(CStr(cell.Value)) = CStr(cell.Value) Else _
            dic.Item(CStr(cell.Value)) = CStr(cell.Value)
        End If
    Next cell
For Each ikey In dic.Keys
        Me.Controls.ComboBox2.AddItem ikey
Next ikey
Next e
End Sub