=ЕСЛИ(C4<=(6/24);((6/24)-C4);0)+ЕСЛИ(D4>=(22/24);(D4-(22/24));0)

Sub высота_строк()

        ' Устанавливаем высоту строк на текущем листе
    With ActiveSheet
        .Rows("174:237").RowHeight = 3
    End With
    
    ' Устанавливаем высоту строк на листе "22"
    Dim ws As Worksheet
    On Error Resume Next ' На случай, если листа "22" не существует
    Set ws = ThisWorkbook.Sheets("22")
    On Error GoTo 0
    
    If Not ws Is Nothing Then
        ws.Rows("19:81").RowHeight = 3
    Else
        MsgBox "Лист с именем '22' не найден!", vbExclamation
    End If
    
    MsgBox "Готово! Высота строк установлена.", vbInformation


  
    Cells(1, 1).Select
    
End Sub

Range("A1:A3000").Select
    Selection.Font.Bold = False

ThisWorkbook.Sheets("гр_тех_обслуж_срс").Range("A1:A3000").Style = "Normal"

Sub Макрос1

Range(Sheets("декабрь").Cells(10, 4), Sheets("декабрь").Cells(17, 4)).Copy Range(Sheets("январь").Cells(10, 5))
 
End Sub

MsgBox ActiveSheet.Tab.Color

If Sheets(b).Tab.ColorIndex = 65535 Then

If Sheets(b).Tab.ColorIndex = 65535 Then
...

Sub sasdfasd()
Dim  b As Integer

For b = 1 To Sheets.Count
Sheets(b).Select
If Sheets(b).Tab.ColorIndex <> 65535 Then
MsgBox ActiveSheet.Tab.Color
End If
Next b

End Sub

Sub sasdfasd()
Dim  b As Integer

For b = 1 To Sheets.Count
Sheets(b).Select
If Sheets(b).Tab.ColorIndex = 65535 Then
MsgBox ActiveSheet.Tab.Color
End If
Next b

End Sub

Sub sasdfasd()
Dim  b As Integer

For b = 1 To Sheets.Count
If Sheets(b).Tab.ColorIndex <> 65535 Then
MsgBox ActiveSheet.Tab.Color
End If
Next b

End Sub

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