Sub Mail_Workbook_1()

Dim X As Long 'Для перебора столбцов базы данных
Dim Y As Long 'Для перебора строк базы данных
Dim Z As Long 'Для перебора строк по спискам адресов получателей
Dim shtX As Worksheet 'Для листа "Базы Данных"
Dim shtY As Worksheet 'Для листа "Списки" с адресами получателей
Dim Mail_Name As String 'Имя адресата для отправки письма

Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set shtX = ThisWorkbook.Sheets("База Данных")
Set shtY = ThisWorkbook.Sheets("Списки")

On Error Resume Next

For X = 1 To shtX.Cells(3, shtX.Columns.Count).End(xlToLeft).Column
      If shtX.Cells(3, X).Value = "Дн до ОБ" Then
          For Y = 4 To 14
              If shtX.Cells(Y, X).Value = 3 Then
                  For Z = 2 To shtY.Cells(shtY.Rows.Count, 1).End(xlUp).Row
                      If shtX.Cells(1, X - 3).Value = shtY.Cells(Z, 1).Value Then
                          Mail_Name = shtY.Cells(Z, 2).Value
                          With OutMail
                    .To = Mail_Name
                    .CC = ""
                    .Subject = "Finished bron"
                    .Body = "Text of the letter"
                    .Attachments.Add "C:\Users\buzdugan\Desktop\.......xlsm"
                    .Send
                          End With
                      End If
                  Next Z
              End If
          Next Y
      End If
Next X

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End Sub

.Attachments.Add "C:\Users\buzdugan\Desktop\.....xlsm"

Sub Mail_Workbook_1()

Dim W As Boolean 'Для проверки на дубли
Dim X As Long 'Для перебора столбцов базы данных
Dim Y As Long 'Для перебора строк базы данных
Dim Z As Long 'Для перебора строк по спискам адресов получателей
Dim shtX As Worksheet 'Для листа "Базы Данных"
Dim shtY As Worksheet 'Для листа "Списки" с адресами получателей
Dim Mail_Name As String 'Имя адресата для отправки письма

Dim OutApp As Object
Dim OutMail As Object

Set shtX = ThisWorkbook.Sheets("База Данных")
Set shtY = ThisWorkbook.Sheets("Списки")

For X = 1 To shtX.Cells(3, shtX.Columns.Count).End(xlToLeft).Column
     W = False
     If shtX.Cells(3, X).Value = "Дн до ОБ" Then
         For Y = 4 To 14
             If shtX.Cells(Y, X).Value = 3 Then
                 For Z = 2 To shtY.Cells(shtY.Rows.Count, 1).End(xlUp).Row
                     If shtX.Cells(1, X - 3).Value = shtY.Cells(Z, 1).Value Then
                         Mail_Name = shtY.Cells(Z, 2).Value
                         Set OutApp = CreateObject("Outlook.Application")
                         Set OutMail = OutApp.CreateItem(0)
                         On Error Resume Next
                         With OutMail
                             .To = Mail_Name
                             .CC = ""
                             .Subject = "Finished bron"
                             .Body = "Text of the letter"
                             .Attachments.Add "C:\Users\buzdugan\Desktop\.......xlsm"
                             .Send
                         End With
                         On Error GoTo 0
                         Set OutMail = Nothing
                         Set OutApp = Nothing
                         W = True
                     End If
                 If W = True Then Exit For
                 Next Z
             End If
         If W = True Then Exit For
         Next Y
     End If
Next X

End Sub

Sub Mail_Workbook_1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

Application.ScreenUpdating = False
Workbooks.OpenText "C:\Users\user11111\AppData\Roaming\Microsoft\Signatures\Aleksey.txt"
For li = ActiveSheet.UsedRange.Row To ActiveSheet.UsedRange.Rows.Count
sSignature = sSignature & vbCrLf & Cells(li, ActiveSheet.UsedRange.Column)
Next li
ActiveWorkbook.Close False

Set OutApp = CreateObject("Outlook.Application")

OutApp.Session.Logon
On Error GoTo cleanup

Set OutMail = OutApp.CreateItem(0)
       
On Error Resume Next
' Change the mail address and subject in the macro before you run it.
..........................
..........................
...........................
On Error GoTo 0
       
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing

Application.ScreenUpdating = True
End Sub

Sub Send_Mail ()

Dim W As Boolean 'Äëÿ ïðîâåðêè íà äóáëè
Dim X As Long 'Äëÿ ïåðåáîðà ñòîëáöîâ áàçû äàííûõ
Dim Y As Long 'Äëÿ ïåðåáîðà ñòðîê áàçû äàííûõ
Dim Z As Long 'Äëÿ ïåðåáîðà ñòðîê ïî ñïèñêàì àäðåñîâ ïîëó÷àòåëåé
Dim shtX As Worksheet 'Äëÿ ëèñòà "Áàçû Äàííûõ"
Dim shtY As Worksheet 'Äëÿ ëèñòà "Ñïèñêè" ñ àäðåñàìè ïîëó÷àòåëåé
Dim Mail_Name As String 'Èìÿ àäðåñàòà äëÿ îòïðàâêè ïèñüìà

Dim OutApp As Object
Dim OutMail As Object

Set shtX = ThisWorkbook.Sheets("Áàçà Äàííûõ")
Set shtY = ThisWorkbook.Sheets("Ñïèñêè")

For X = 1 To shtX.Cells(3, shtX.Columns.Count).End(xlToLeft).Column
       W = False
       If shtX.Cells(3, X).Value = "Äí äî ÎÁ" Then
           For Y = 4 To 2000
               If shtX.Cells(Y, X).Value = 1 Or shtX.Cells(Y, X).Value = 2 Or shtX.Cells(Y, X).Value = 3 Or shtX.Cells(Y, X).Value = 4 Then
                   For Z = 2 To shtY.Cells(shtY.Rows.Count, 1).End(xlUp).Row
                       If shtX.Cells(1, X - 3).Value = shtY.Cells(Z, 1).Value Then
                           Mail_Name = shtY.Cells(Z, 2).Value
                           Set OutApp = CreateObject("Outlook.Application")
                           Set OutMail = OutApp.CreateItem(0)
                           On Error Resume Next
                           With OutMail
                     .Display
                     .To = Mail_Name
                     .CC = "a.buzdugan@awt.ru"
                     .Subject = "Îêîí÷àíèå Áðîíè íà îáîðóäîâàíèå"
                     .HTMLBody = "Óâàæàåìûå Êîëëåãè! Ïðîøó Âàñ ïðîâåðèòü ñîñòîÿíèå áðîíè â ñîîòâåòñòâèè ñ âëîæåííûì ôàéëîì. Ñíÿòü/ïðîäëèòü.  äåíü îêîí÷àíèÿ áðîíè Âàøà áðîíü àâòîìàòè÷åñêè óäàëÿåòñÿ ñèñòåìîé." & .HTMLBody
                     .Attachments.Add "\\Files\documents\-ÍÎÂÀß ÑÒÐÓÊÒÓÐÀ-\Äåïàðòàìåíò ïîñòàâîê è òîðãîâûõ îïåðàöèé\Îáîðóäîâàíèå\Áðîíèðîâàíèå è íàëè÷èå îáîðóäîâàíèÿ\Áðîíèðîâàíèå è íàëè÷èå îáîðóäîâàíèÿ\Íàëè÷èå îáîðóäîâàíèÿ íà ñêëàäå.xlsm"
                     .Send
                           End With
                           On Error GoTo 0
                           Set OutMail = Nothing
                           Set OutApp = Nothing
                           W = True
                       End If
                       If W = True Then Exit For
                   Next Z
               End If
               If W = True Then Exit For
           Next Y
       End If
Next X
End Sub