ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:="C:\Users\kols0875\Desktop\водосчётчик\2024\для отправки в СетиНикеля\показания на " & Date & ".pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False

MkDir ActiveWorkbook.Path & "\" & REPORTS_FOLDER

Sub Передача()


'
'

'
  Dim k As Integer, i As Integer, z As Integer, Mass As Variant

    
    ' название подпапки, в которую по-умолчанию будет предложено сохранить файл
    Const REPORTS_FOLDER = "для отправки в СетиНикеля"
    ' создаём папку для файла, если её ещё нет
    'On Error Resume Next
    MkDir ActiveWorkbook.Path & "\" & REPORTS_FOLDER
    
    ' выбираем стартовую папку
    ChDrive Left(ActiveWorkbook.Path, 1): ChDir ActiveWorkbook.Path & "\" & REPORTS_FOLDER
 
    ' вывод диалогового окна для запроса имени сохраняемого файла
    
    
'ActiveWindow.SelectedSheets.PrintOut Copies:=1
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:="C:\Users\kols0875\Desktop\водосчётчик\2024\для отправки в СетиНикеля\показания на " & Date & ".pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False
    

    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
    Shell ("OUTLOOK")
    Application.Wait (Now + TimeValue("0:00:10"))
    'пробуем подключиться к 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 = "@mail.ru"   
    sSubject = ""   
    sBody = ""   
    sAttachment = "C:\Users\kols0875\Desktop\водосчётчик\2024\для отправки в СетиНикеля\показания на " & Date & ".pdf"  '
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        .Display 'Send, если необходимо  отправлять без просмотра
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
    
    End Sub

 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                    Filename:="C:\Users\kols0875\Desktop\показания на " & Date & ".pdf", _
                                    Quality:=xlQualityStandard, _
                                    IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, _
                                    OpenAfterPublish:=False

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
    Shell ("OUTLOOK")
    Application.Wait (Now + TimeValue("0:00:10"))
    'пробуем подключиться к 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)   'создаем новое сообщение

Sub QQQ
Dim wb As Workbook
Set wb = ActiveWorkbook
Set PZ = Sheets("Лист2")
Set L1 = Sheets("Лист1")
For a = 4 To 17
PZ.Cells(6, 1) = L1.Cells(a, 1)

 PZ.Copy                                                  '
ActiveWorkbook.SaveAs wb.Path & "\" & PZ.Cells(6, 1).Value & ".xlsx" 

Next a


End Sub

For a = 2 To 32
If Cells(a, 3) >= 8 And Cells(a, 4) <= 16 And (Weekday(Cells(a, 1)) = 1 Or Weekday(Cells(a, 1)) = 7) Then q = 1  'если выходной, и интервал внутри 8-16
If (Cells(a, 3) >= 8 And Cells(a, 3) <= 16) And Cells(a, 4) >= 16 And (Weekday(Cells(a, 1)) = 1 Or Weekday(Cells(a, 1)) = 7) Then q1 = 1  'если выходной, и нижний конец внутри интервала 8-16, а верхний за пределами
Next a

For a = 2 To 32

Cells(a, 8) = DateDiff("h", Cells(a, 3), Cells(a, 4))

Next a

=ЕСЛИ(И(C19>=8; D19<=17);1;0)

=ЕСЛИ(И(ВРЕМЯ(C19;0;0)>=ВРЕМЯ(8;0;0); ВРЕМЯ(D19;0;0)<=ВРЕМЯ(17;0;0));1;0)