Sub Fix_СF_Hell()
 
    'создаем ссылки на диапазоны
    Set rngAll = Selection
    Set rngRow1 = Selection.Rows(1)
    Set rngRow2 = Selection.Rows(2)
    Set rngRowLast = Selection.Rows(rngAll.Rows.Count)
 
    'удаляем все правила форматирования со всех строк кроме первой
    Range(rngRow2, rngRowLast).FormatConditions.Delete
     
    'копируем форматы с первой строки на все остальные
    rngRow1.Copy
    Range(rngRow1, rngRowLast).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
     
End Sub

=ЕСЛИ(ИЛИ(ЕПУСТО(B5));"";ТЕКСТ(ПРАВСИМВ(СУММ(КОДСИМВ(ПСТР([@2];СТРОКА(ДВССЫЛ("a1:a"&ДЛСТР([@2])));1))^3);7);"11-00000"))

=ПРАВБ(СУММПРОИЗВ(КОДСИМВ(ПСТР(B6;СТРОКА(A$1:ИНДЕКС(A:A;ДЛСТР(B6)));2))^3;СТРОКА(A$1:ИНДЕКС(A:A;ДЛСТР(B6))));8)

=ЕСЛИ([@1]="";"";ЕСЛИ(C5="";ЕСЛИ([@1]="";"";"11"&ТЕКСТ(A5;"00000"));C167))

=ИНДЕКС(Ном_док;ПОИСКПОЗ(C8;Тип_док;0))&ТЕКСТ(СЧЁТЕСЛИ(C$1:C7;C8)+1;"-000")&ТЕКСТ(B8;"\/ГГ")

=(B55<>"")*СЧЁТЗ($B$5:B55)

=ЕСЛИ(ИЛИ(ЕПУСТО(B55));"";"12"&ТЕКСТ(A55;"00000"))

=ЕСЛИ([@2]="";"";ЕСЛИ(F10="";ЕСЛИ([@2]="";"";ТДАТА());F10))

=ЕСЛИ(ЕПУСТО('Данные'!N31);"";ИНДЕКС(Таблица7[2];ПОИСКПОЗ('Данные'!N31;ЗНАЧЕН(Таблица7[3]);0)))

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
dan$ = ActiveCell.Value
rez$ = "'"
If Mid(dan, 6, 1) <> " " And Mid(dan, 5, 1) <> " " Then
    For i& = 0 To Len(dan) Step 4
        rez = rez & Mid(dan, i + 1, 4) & " "
    Next i
Else
    rez$ = Replace(dan, " ", "")
End If
ActiveCell.Value = rez
End Sub

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    strPath = "C:\Users\Admin\Desktop"     'папка для сохранения резервной копии
    
    SheetName = Sheets("Данные").Range("L1").Value
      
    FinalFileName = strPath & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF
    FinalFileName1 = strPath & SheetName & ".xlsm" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в xlsm
      
    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If
  
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
        
    FileNameXls = FinalFileName1
    ActiveWorkbook.SaveCopyAs Filename:=FileNameXls

        
    Application.ScreenUpdating = True
    MsgBox "Бланк обмера " & SheetName & " сохранён в формате PDF и XLSM!", vbInformation, "Конец"
        Exit Sub
    Sheets("Бланк_обмера").Select
    
End Sub

Sub Backup_Active_Workbook()
    Dim x As String
    strPath = "c:\TEMP"     'папка для сохранения резервной копии
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then ' если путь существует - сохраняем копию книги, добавляя дату-время
        strDate = Format(Now, "dd-mm-yy hh-mm")
        FileNameXls = strPath & "\" & Sheets("Данные").Range("A1").Value & " " & strDate & ".xlsm"   'или xlsm
        ActiveWorkbook.SaveCopyAs FileName:=FileNameXls
    Else 'если путь не существует - выводим сообщение
        MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
    End If
End Sub

Sub Печать()
Dim CellValue As String
Dim Path As String
Dim FinalFileName As String
    Application.ScreenUpdating = False
    Path = "C:\Users\Admin\Desktop\" 'Путь сохранения файла
    SheetName = Sheets("Данные").Range("L1").Value
     
    FinalFileName = Path & SheetName & ".pdf" 'Формируем итоговый путь и название файла
        'запоминаем имя выбранного листа - будем подставлять в путь для сохранения в PDF
 
     
    Sheets(Array("Бланк_обмера", "Стена_A", "Стена_B", "Стена_C", "Стена_D", "Потолок", "Пол")).Select
        'проверка - пуст лист или нет. Если пуст, то сообщаем
    If WorksheetFunction.CountA(ActiveSheet.Cells) = 0 Then
        MsgBox "Лист '" & SheetName & "' пуст! Невозможно его сохранить в PDF!", vbInformation, "Внимание"
        StartSheet.Select
        Exit Sub
    End If
 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FinalFileName, Quality:= _
    xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
 
    'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    'ActiveWorkbook.Path & "\" & "Бланк обмера '" & SheetName & ".pdf", Quality:= _
    'xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    'OpenAfterPublish:=True
         
    Application.ScreenUpdating = True
    MsgBox "Бланк обмера " & SheetName & " сохранён в PDF!", vbInformation, "Конец"
 
    Sheets("Бланк_обмера").Select
     
End Sub

Sub HideColumnsRows()
   With Worksheets("Литс 1")
      .Columns(14).Hidden = True
      .Rows("5:9").Hidden = True
   End With
End Sub

Sub СкрытьБелыхИ_хarr()
Dim с As Date
Dim d As Single
'Больше не обновляем страницы после каждого действия
'Application.ScreenUpdating = False
'Отключаем события
'Application.EnableEvents = False
'Расчёты переводим в ручной режим
'Application.Calculation = xlCalculationManual
c = Time
    If ActiveSheet.ListObjects.Count = 0 Then Exit Sub
      
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.EntireRow.Hidden = False
    Dim tb As ListObject
    For Each tb In ActiveSheet.ListObjects
        JobTb tb
    Next
    Application.ScreenUpdating = True
        d = (Time - c) * 24 * 60 * 60
'Расчёты переводим в автоматический режим
'Application.Calculation = xlCalculationAutomatic
'Включаем события
'Application.EnableEvents = True
'Включаем обновление страниц после каждого действия
'Application.ScreenUpdating = True
 
    MsgBox "Время выполнения макроса составило: " & d & " c.", vbInformation, "Отчет"
End Sub
Private Sub JobTb(tb As ListObject)
    Dim flag As Boolean
    Dim cl As Range
    Dim yy As Long
    Dim arr As Variant
    arr = tb.DataBodyRange.Columns(14).Value
     
    'For Each cl In tb.DataBodyRange.Columns(1).Cells
    For yy = 1 To UBound(arr, 1)
        flag = False
        'If cl.Cells(1, 15).Value = "х" Then
        If arr(yy, 1) = "х" Then
            flag = True
        End If
        Set cl = tb.DataBodyRange.Cells(yy, 1)
        Select Case cl.Interior.Color
        Case 11389944, 14277081
        Case Else
            flag = True
        End Select
          
        If flag Then cl.EntireRow.Hidden = True
    Next
End Sub

    For Each cl In tb.DataBodyRange.Columns(1).Cells
    'For yy = 1 To UBound(arr, 1)
        flag = False
        If cl.Cells(1, 14).Value = "х" Then
        'If arr(yy, 1) = "х" Then

Sub СкрытьБелыхИ_х()

Dim с As Date
Dim d As Single
'Больше не обновляем страницы после каждого действия
Application.ScreenUpdating = False
'Отключаем события
Application.EnableEvents = False
'Расчёты переводим в ручной режим
Application.Calculation = xlCalculationManual
c = Time
    If ActiveSheet.ListObjects.Count = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.EntireRow.Hidden = False
    Dim tb As ListObject
    For Each tb In ActiveSheet.ListObjects
        JobTb tb
    Next
    Application.ScreenUpdating = True
    d = (Time - c) * 24 * 60 * 60
'Расчёты переводим в автоматический режим
Application.Calculation = xlCalculationAutomatic
'Включаем события
Application.EnableEvents = True
'Включаем обновление страниц после каждого действия
Application.ScreenUpdating = True

    MsgBox "Время выполения макроса составило: " & d & " c.", vbInformation, "Отчет"
End Sub
Private Sub JobTb(tb As ListObject)
    Dim flag As Boolean
    Dim cl As Range
    For Each cl In tb.DataBodyRange.Columns(1).Cells
        flag = False
        If cl.Cells(1, 14).Value = "х" Then
            flag = True
        End If
        Select Case cl.Interior.Color
        Case 11389944, 14277081
        Case Else
            flag = True
        End Select
        
        If flag Then cl.EntireRow.Hidden = True
    Next
End Sub