Sub Send_Mail()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String

    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    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 = "AddressTo@mail.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Автоотправка"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Привет от Excel-VBA"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = "C:\Temp\Книга1.xls"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
    
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With

    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton5_Click() 'Код для сохранения данных на лист Журнал реестра на отгрузку

q = MsgBox("Вы уверены что хотите сохранить в PDF???", vbOKCancel)
If q = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

'Код сохранения
Range(ActiveSheet.PageSetup.PrintArea).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\Дом\Downloads\Диспечерезация(2).pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

q = MsgBox("Вы уверены что хотите отправить сохраненный файл по почте???", vbOKCancel)
If q = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

'Код для отправки данного файла на почту Outlook

Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
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 = "a.anisimov@gradindustry.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
sSubject = "Реестр на отгрузку"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
sBody = "Здравствуйте направляю вам реестр на отгрузку"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
sAttachment = "C:\Users\Дом\Downloads\Диспечерезация(2).pdf"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
'создаем сообщение
With objMail
.To = sTo 'адрес получателя
.CC = "" 'адрес для копии
.BCC = "" 'адрес для скрытой копии
.Subject = sSubject 'тема сообщения
.Body = sBody 'текст сообщения
'.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
.Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
.Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True   
  
q = MsgBox("Вы уверены что хотите сохранить данные в ЖУРНАЛ РЕЕСТРА НА ОГРУЗКУ???", vbOKCancel)
If q = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

'Код для сохранения данных в общий журнал реестра
    Dim shSheetf As Worksheet
    Dim shSheett As Worksheet
    ' Dim lStartSheet_("Реестр на отгрузку") As Long, lEndSheet_("Реестр на отгрузку") As Long
    Dim lLastRow As Long
    Dim i As Long
    'Даём листам имена "("Реестр на отгрузку")" и "shSheet_("журнал реестра на отгрузку")",
    'чтобы было удобнее писать код.
    Set shSheetf = Worksheets("Реестр на отгрузку")
    Set shSheett = Worksheets("журнал реестра на отгрузку")
    lStartSheet = 11
    lEndSheet = shSheetf.Cells(Rows.Count, 1).End(xlUp).Row
    'Указываем, с какой строки начать вставлять данные на второй лист.
    lLastRow = shSheett.Cells(Rows.Count, 2).End(xlUp).Row + 1
    'Двигаем по первому листу по столбцу "A".
    For i = lStartSheet To lEndSheet
    If Not shSheetf.Cells(i, 1).Value = Empty Then
    'Перносим данные на второй лист.
    shSheett.Cells(lLastRow, 2).Value = shSheetf.Cells(i, 1).Value
    For X = 2 To 12
    shSheett.Cells(lLastRow, X + 1).Value = shSheetf.Cells(i, X).Value
    Next X
    'Изменяем переменную "lLastRow",
    'чтобы данные уже вставлять в следующую строку.
    lLastRow = lLastRow + 1
    End If
    Next i
    Range(Cells(11, 1), Cells(lEndSheet, 70)).ClearContents

    MsgBox "Данные перенесены на Лист Журнал реестра на отгрузку..."
End Sub

Private Sub CommandButton5_Click() 'Код для сохранения данных на лист Журнал реестра на отгрузку
    
    If MsgBox("Вы уверены что хотите сохранить в PDF???", vbOKCancel) = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

    'Код сохранения в ПДФ
    Dim sAttachment As String
    sAttachment = "C:\TEMP\" & Replace(ActiveSheet.Name, " ", "_") & ".pdf"
    
    Range(ActiveSheet.PageSetup.PrintArea).ExportAsFixedFormat Type:=xlTypePDF, _
                    Filename:=sAttachment, _
                    Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False

    If MsgBox("Вы уверены что хотите отправить сохраненный файл по почте???", vbOKCancel) = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

    'Код для отправки данного файла на почту Outlook
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String
    Application.ScreenUpdating = False
    On Error Resume Next
    
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    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 = "e.tatchenkova@m-uptk.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "Реестр на отгрузку"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = "Здравствуйте направляю вам реестр на отгрузку"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With

    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True

    If MsgBox("Вы уверены что хотите сохранить данные в ЖУРНАЛ РЕЕСТРА НА ОГРУЗКУ???", vbOKCancel) = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

    'Код для сохранения данных в общий журнал реестра
    Dim shSheetf As Worksheet
    Dim shSheett As Worksheet
    ' Dim lStartSheet_("Реестр на отгрузку") As Long, lEndSheet_("Реестр на отгрузку") As Long
    Dim lLastRow As Long
    Dim i As Long
    'Даём листам имена "("Реестр на отгрузку")" и "shSheet_("журнал реестра на отгрузку")",
    'чтобы было удобнее писать код.
    Set shSheetf = Worksheets("Реестр на отгрузку")
    Set shSheett = Worksheets("журнал реестра на отгрузку")
    lStartSheet = 11
    
    lEndSheet = shSheetf.Cells(Rows.Count, 1).End(xlUp).Row
    
    'Указываем, с какой строки начать вставлять данные на второй лист.
    lLastRow = shSheett.Cells(Rows.Count, 2).End(xlUp).Row + 1
    
    'Двигаем по первому листу по столбцу "A".
    For i = lStartSheet To lEndSheet
        If Not shSheetf.Cells(i, 1).Value = Empty Then
            'Перносим данные на второй лист.
            shSheett.Cells(lLastRow, 2).Value = shSheetf.Cells(i, 1).Value
            For X = 2 To 12
                shSheett.Cells(lLastRow, X + 1).Value = shSheetf.Cells(i, X).Value
            Next X
            'Изменяем переменную "lLastRow",
            'чтобы данные уже вставлять в следующую строку.
            lLastRow = lLastRow + 1
        End If
    Next i
    Range(Cells(11, 1), Cells(lEndSheet, 70)).ClearContents
    MsgBox "Данные перенесены на Лист Журнал реестра на отгрузку..."
    
    If MsgBox("Вы уверены что хотите удалить следующий PDF файл: " & sAttachment & " ???", vbOKCancel) = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий
    
    If Dir(sAttachment, 16) = "" Then
        MsgBox "Нет такого файла", vbCritical, "Ошибка"
    Else
        Kill sAttachment
    End If
End Sub

Private Sub CommandButton4_Click() 'Код для сохранения данных на лист Общий журнал заявок на транспор

q = MsgBox("Вы уверены что хотите сохранить в PDF???", vbOKCancel)
If q = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

'Код сохранения
Dim sAttachment As String
sAttachment = "C:\Users\a.anisimov\Desktop\" & ActiveSheet.Name & ".pdf"
Range(ActiveSheet.PageSetup.PrintArea).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\a.anisimov\Desktop\" & ActiveSheet.Name & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

q = MsgBox("Вы уверены что хотите отправить сохраненный файл по почте???", vbOKCancel)
If q = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

'Код для отправки данного файла на почту Outlook
Dim objOutlookApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
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 = "a.anisimov@gradindustry.ru"    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
sSubject = "Заявка на транспорт БЕТОМАКСУ"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
sBody = "Здравствуйте направляю вам Заявку на автотранспорт"    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
sAttachment = "C:\Users\a.anisimov\Desktop\" & ActiveSheet.Name & ".pdf"    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
'создаем сообщение
With objMail
.To = sTo 'адрес получателя
.CC = "" 'адрес для копии
.BCC = "" 'адрес для скрытой копии
.Subject = sSubject 'тема сообщения
.Body = sBody 'текст сообщения
'.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
.Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
.Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True

        
q = MsgBox("Вы уверены что хотите сохранить данные в Общий журнал заявок на транспорт???", vbOKCancel)
If q = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий

'Код для сохранения данных в общий журнал заявок на транспорт
    Dim shSheetf As Worksheet
    Dim shSheett As Worksheet
    ' Dim lStartSheet_("Заявка на транспорт БЕТОМАКСУ") As Long, lEndSheet_("Заявка на транспорт БЕТОМАКСУ") As Long
    Dim lLastRow As Long
    Dim i As Long
    'Даём листам имена "("Заявка на транспорт БЕТОМАКСУ")" и "shSheet_("Общий журнал заявок на транспор")",
    'чтобы было удобнее писать код.
    Set shSheetf = Worksheets("Заявка на транспорт БЕТОМАКСУ")
    Set shSheett = Worksheets("Общий журнал заявок на транспор")
    lStartSheet = 10
    lEndSheet = shSheetf.Cells(Rows.Count, 1).End(xlUp).Row
    'Указываем, с какой строки начать вставлять данные на второй лист.
    lLastRow = shSheett.Cells(Rows.Count, 2).End(xlUp).Row + 1
    'Двигаем по первому листу по столбцу "A".
    For i = lStartSheet To lEndSheet
    If Not shSheetf.Cells(i, 1).Value = Empty Then
    'Перносим данные на второй лист.
    shSheett.Cells(lLastRow, 2).Value = shSheetf.Cells(i, 1).Value
    For X = 2 To 11
    shSheett.Cells(lLastRow, X + 1).Value = shSheetf.Cells(i, X).Value
    Next X
    'Изменяем переменную "lLastRow",
    'чтобы данные уже вставлять в следующую строку.
    lLastRow = lLastRow + 1
    End If
    Next i
    Range(Cells(5, 1), Cells(lEndSheet, 9)).ClearContents
    MsgBox "Данные перенесены на Лист Общий журнал заявок на транспорт..."
    
    q = MsgBox("Вы уверены что хотите удалить PDF файл???", vbOKCancel)
If q = vbCancel Then Exit Sub 'Сообщения для утверждения ваших действий
    If Dir(sAttachment, 16) = "" Then
MsgBox "Нет такого файла", vbCritical, "Ошибка"
Else
Kill sAttachment
End If
    
End Sub