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

 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