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

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

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\показания на " & 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)

=A3 & " рублей"

Worksheets("Лист1").Copy After:=Worksheets("Лист1")

=ЕСЛИ(B49=""; "";ЕСЛИ(B49="нет";"";"Петров"))

RB.Cells(48 + si, 21).FormulaLocal="=ЕСЛИ(B49=""; "";ЕСЛИ(B49="нет";"";"Петров"))"

="следующих требований"  &  Chr(10)  &  "1. должны исходить "

Sub Спис_примечаний()
Dim k As Integer, b As Integer, cell As Object, v As String, PR As Object
'Sheets.Add.Name = "Примечание"
Set PR = Sheets("Примечание")
k = 1
For b = 2 To Sheets.Count ' цикл по всем листам книги
For Each cell In Range("A1:D70")   ' цикл по диапазону на каждом листе
        If cell.Comment Is Nothing Then
        Else
            v = v & cell.Row & ", "
        End If
    Next cell
    PR.Cells(k, 1) = Sheets(b).Name & " " & v
    k = k + 1
Next b
End Sub

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
        "адрес гиперссылки", TextToDisplay:="текст гиперссылки"
 

Sub protocol()

Dim otv3 As String, Filename As String

otv3 = InputBox("ввести название контрагента", "ввод контрагента", "ООО  ")
Cells(9, 2) = "Потребитель: " & otv3

    On Error Resume Next
    ' название подпапки, в которую по-умолчанию будет предложено сохранить файл
    Const REPORTS_FOLDER = "протоколы для контрагентов"
    ' создаём папку для файла, если её ещё нет
    MkDir ActiveWorkbook.Path & "\" & REPORTS_FOLDER
    ' выбираем стартовую папку
    ChDrive Left(ActiveWorkbook.Path, 1): ChDir ActiveWorkbook.Path & "\" & REPORTS_FOLDER
 
    ' вывод диалогового окна для запроса имени сохраняемого файла
    Filename = "протокол_для_" & Cells(9, 2) & ".xlsm"
     'Filename = "протокол.xlsx"
    ' копируем активный лист (при этом создаётся новая книга)
  
    Err.Clear: Sheets("PR").Copy: DoEvents
    If Err Then Exit Sub    ' произошла какая-то ошибка при попытке копирования листа
    ActiveSheet.Buttons.Delete

        ActiveWorkbook.SaveAs Filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled

        ActiveWorkbook.Close False

End Sub

'  Процедуры ниже заполняют протокол данными со счётчика
'
Public Function ОбработатьЧасовой(Wrs As Excel.Worksheet, ByVal До As Date, ByVal Всего As Integer) As Integer
Dim i As Integer, j As Integer, k As Integer
Dim Регистр As Integer, iDay As Integer
Dim iStr As Integer, iPos As Integer
Dim День As Date
Dim a
  With Wrs
        If kTab = 0 Then Exit Function
    День = До - Всего + 1
    iDay = Sect(Sect_Tbl, 1) + TblBeg
    For k = 1 To Всего
        For i = 1 To kTab               ' Цикл по регистрам
         If ПрерватьЧтение Then
            ОбработатьЧасовой = 1
            Exit Function
          End If
           Регистр = sTab(2, i)
            iPos = sTab(1, i)
            iStr = iDay
            ' *************************************
            a = MC601_СчитатьЧасовой(Регистр, День)
            ' *************************************
 ИндикаторЕщё (1)
            For j = 24 To 1 Step -1             ' Записываем в блок
                .Cells(iStr, iPos) = a(j)
                iStr = iStr + 1
              Next j
          Next i
        iDay = iDay + TblLen
        День = День + 1
      Next k
  End With
End Function

Sheets(Array("Лист1", "Лист2")).Select

=СЧЁТЕСЛИМН(A1:A21; "<01.04.2021")

Sub выравнивание_строк()
     Set TA = Sheets("Лист1") ' название листа который служит эталоном

     For b = 4 To Sheets.Count  ' цикл по всем листам книги, исключая лист - эталон
         For c = 1 To 48
               Sheets(b).Select
               Cells(c, 1).RowHeight = TA.Cells(c, 1).RowHeight
          Next c
     Next b
End Sub

Sheets(b).Select

Cells(c, 1).RowHeight = TA.Cells(c, 1).RowHeight

If DateDiff("yyyy", Now, Cells(a, k)) < 1 Then Cells(a, 13) = Cells(a, k)

Next c

If DatePart("yyyy", Cells(a, 13)) <= DatePart("yyyy", Now) Then Cells(a, 13) = "ñïèñàòü"
Next a

DateDiff("yyyy", Now, Cells(a, k))

For a = 15 To 300
Cells(a, 1).Formula = "=ЕСЛИ(ЕПУСТО(RC[1]);"";СЧЕТЗ(RC[1]:R15C2))"
Next a

For a = 15 To 300
Cells(a, 1) = "=ЕСЛИ(ЕПУСТО(RC[1]);"";СЧЕТЗ(RC[1]:R15C2))"
Next a

Function PrevMonthName$()
  PrevMonthName = Split("декабрь январь февраль март апрель май июнь июль август сентябрь октябрь ноябрь декабрь")(Month(Now) - 1)
End Function

Sub ген()

Dim mes As String, objClpb As New DataObject  

otv2 = InputBox("ввести месяц в формате 1, 2 и т.д. (13-по умолчанию прошлый) иначе вводить номер требуемого месяца", "ввод месяца", "13")
                Select Case otv2
    Case "01"
mes = "январь"
    Case "2"
mes = "февраль"
    Case "3"
mes = "март"
    Case "4"
mes = "апрель"
    Case "5"
mes = "май"
    Case "6"
mes = "июнь"
    Case "7"
mes = "июль"
    Case "8"
mes = "август"
    Case "9"
mes = "сентябрь"
    Case "10"
mes = "октябрь"
    Case "11"
mes = "ноябрь"
    Case "12"
mes = "декабрь"
    Case "13"
mes = PrevMonthName

 End Select
  
   Range("A1:A14").Select
   Selection.ClearContents

    Cells(1, 1) = "отопление_" & mes

    sStr = Cells(1, 1)
    objClpb.SetText sStr
    objClpb.PutInClipboard
End Sub

, objClpb As New DataObject

=ПРЕДСКАЗ(E3;B6:B7;A6:A7)

Sheets("январь").Range(Sheets("январь").Cells(10, 4), Sheets("январь").Cells(16, 4)).Select
   Selection.ClearContents