Sub save_awb_w_val()
    Dim mainBook As Workbook, mainWBname As String, copiedBook As Workbook
    Application.ScreenUpdating = False
    Set mainBook = ActiveWorkbook
    mainWBname = mainBook.FullName
    mainBook.SaveAs Filename:=mainBook.Path & "\" & Mid(mainBook.Name, 1, InStrRev(mainBook.Name, ".") - 1) & _
    Format(Now, "-yyyy_mm_dd-hh_mm_ss-") & "val." & Mid(mainBook.Name, InStrRev(mainBook.Name, ".") + 1, 4)
    Set copiedBook = ActiveWorkbook
    copiedBook.Worksheets("вводные").UsedRange.Formula = _
    copiedBook.Worksheets("вводные").UsedRange.Value
    Workbooks.Open mainWBname
    copiedBook.Close SaveChanges:=True
    Application.ScreenUpdating = True
End Sub

ThisWorkbook.Protect...
ThisWorkbook.Unprotect...

Sub copyChecked()
    Dim i&, lastRow&, nextEmptyRow&
    lastRow = Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 4 To lastRow
        nextEmptyRow = Worksheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row + 1
        If Worksheets("Лист1").Cells(i, 3).Value = True Then
            Range(Worksheets("Лист1").Cells(i, 1), Worksheets("Лист1").Cells(i, 3)).Copy
            Worksheets("Лист2").Cells(nextEmptyRow, 1).PasteSpecial Paste:=xlPasteValues
            With Worksheets("Лист2").Range("A" & nextEmptyRow & ":I" & nextEmptyRow).Borders
                .LineStyle = xlContinuous
                .Weight = xlHairline
            End With
        End If
    Next i
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Worksheets("Лист2").Activate
End Sub

Sub FixTable()
    Dim lastRow As Long, i As Long, rngTemp As Range, newWsh As Worksheet
    lastRow = Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
    Set newWsh = ActiveWorkbook.Worksheets.Add(After:=Worksheets("Лист1"))
    Application.ScreenUpdating = False
    For i = 1 To lastRow
        If Worksheets("Лист1").Cells(i, 1).IndentLevel = 0 Then
            Set rngTemp = Worksheets("Лист1").Cells(i, 1)
        End If
        If Worksheets("Лист1").Cells(i, 1).IndentLevel = 0 Then
            rngTemp.Copy Range(newWsh.Cells(i, 1), newWsh.Cells(i, 2))
        ElseIf Worksheets("Лист1").Cells(i, 1).IndentLevel = 1 Then
            rngTemp.Copy newWsh.Cells(i, 1)
            Worksheets("Лист1").Cells(i, 1).Copy newWsh.Cells(i, 2)
        End If
    Next i
    newWsh.Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub

Sub text()
    Dim str1
    str1 = "1" & "." & "1"
    'Сначала задаем текстовый формат
    Worksheets("Лист1").Range("A1").NumberFormat = "@"
    'Потом записываем занчение
    Worksheets("Лист1").Range("A1") = str1
End Sub

Sub MainMacro()
  With Worksheets("Лист1")
    ClearRg .Cells.Find("мин", , xlValues, xlWhole, SearchFormat:=False)
    ClearRg .Cells.Find("макс")
  End With
End Sub

Sub ClearRg(rg As Range)
  If rg Is Nothing Then Exit Sub
  rg.EntireColumn.FormatConditions.Delete
  rg.Resize(4, 1).ClearFormats' Эта строчка!
  'rg.Resize(4, 1).ClearContents
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A1:B1")) Is Nothing Then Exit Sub
    With ActiveSheet.PageSetup
        .OddAndEvenPagesHeaderFooter = True
        .DifferentFirstPageHeaderFooter = True
        'Для 1-й и всех нечётных страниц из ячейки "A1"
        .FirstPage.CenterHeader.Text = Range("A1").Value
        .FirstPage.RightFooter.Text = Range("A1").Value
        'Для всех чётных страниц из ячейки "B1"
        .EvenPage.CenterHeader.Text = Range("B1").Value
        .EvenPage.LeftFooter.Text = Range("B1").Value
    End With
End Sub

Sub DocxToPDF_WithFolderName()
    Dim objDoc As Document
    Dim strFile As String, strFolderPath As String, strFolderOnly As String
    Application.ScreenUpdating = False
    strFolderPath = Application.ActiveDocument.Path & Application.PathSeparator
    strFolderOnly = Split(strFolderPath, "\")(UBound(Split(strFolderPath, "\")) - 1)
    strFile = Dir(strFolderPath & "*.docx", vbNormal)
    While strFile <> ""
        Set objDoc = Documents.Open(FileName:=strFolderPath & strFile)
        objDoc.ExportAsFixedFormat _
        OutputFileName:=strFolderPath & strFolderOnly & "_" & Mid(strFile, 1, Len(strFile) - 5) & ".pdf", _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
        OptimizeFor:=wdExportOptimizeForPrint, _
        Range:=wdExportAllDocument, Item:=wdExportDocumentContent
        objDoc.Close
        Set objDoc = Nothing
        strFile = Dir()
    Wend
    Application.ScreenUpdating = True
    'Application.Quit
End Sub

Sub SavePicturesOfSel()
    Dim i As Long, txtFolderPath As String, strFileName As String, selRange As Range, Hypotenuse As Double
    txtFolderPath = ActiveWorkbook.Path
    If ActiveSheet.Shapes.Count = 0 Then
        MsgBox "А картинок то нету!"
        Exit Sub
    End If
    If TypeName(Selection) <> "Range" Then
        Exit Sub
    Else
        Set selRange = Selection
    End If
    If ActiveSheet.ChartObjects.Count > 0 Then ActiveSheet.ChartObjects.Delete
    For i = 1 To ActiveSheet.Shapes.Count
        'If ActiveSheet.Shapes(i).Type = 13 Then 'MsoShapeType.msoPicture(если только картинки)
        If Not Intersect(ActiveSheet.Shapes(i).TopLeftCell, selRange) Is Nothing Then
        ActiveSheet.Shapes(i).Copy
        strFileName = ActiveSheet.Shapes(i).Name
            With ActiveSheet.ChartObjects.Add(0, 0, ActiveSheet.Shapes(i).Width, ActiveSheet.Shapes(i).Height).Chart
                DoEvents
                If ActiveSheet.Shapes(i).Rotation > 0 Then
                    Hypotenuse = Sqr(ActiveSheet.Shapes(i).Width ^ 2 + ActiveSheet.Shapes(i).Height ^ 2)
                    .ChartArea.Width = Hypotenuse
                    .ChartArea.Height = Hypotenuse
                End If
                .ChartArea.Select
                .Paste
                .Shapes(1).Left = (.ChartArea.Width - .Shapes(1).Width) / 2
                .Shapes(1).Top = (.ChartArea.Height - .Shapes(1).Height) / 2
                .Export Filename:=txtFolderPath & "\" & strFileName & ".jpg"
                .Parent.Delete
            End With
        End If
        'End If
    Next i
    selRange.Select
    'Открыть папку с картинками
    Shell "explorer.exe " & txtFolderPath, vbMaximizedFocus
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim myRange As Range, WSh2 As Worksheet
    If Intersect(Target, Range("A1")) Is Nothing Then End
    Set WSh2 = Worksheets("Лист2")
    Set myRange = WSh2.Range(WSh2.Range("A5"), WSh2.Range("A5").End(xlDown).End(xlToRight))
    Select Case Range("A1").Text
        Case "Понедельник", "Вторник", "Среда", "Четверг", "Пятница", "Суббота", "Воскресенье"
            myRange.AutoFilter Field:=1, Criteria1:=Worksheets("Лист1").Range("A1").Text
        Case "Все"
            On Error Resume Next: Worksheets("Лист2").ShowAllData: On Error GoTo 0
    End Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A2:A5000")) Is Nothing Then
     'если это номер договора (есть слеш /) - не делать ничего
        If InStr(1, Target, "/") > 0 Then Exit Sub
     'если это трёхзначное число - выполнить макрос ZapIpso
        If Len(Target) = 3 Then
            Call ZapIpso
     'если это число более трёх знаков - выполнить макрос Spacing
        ElseIf Len(Target) > 3 Then
            Call Spacing
        End If
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A1")) Is Nothing Then End
    With Worksheets("Лист2")
        .Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=Worksheets("Лист1").Range("A1").Text
    End With
End Sub

=TEXT(A1,"yyyymmdd")
=TEXT(A2,"hhmm")

Sub OneFilter(ByVal crit As Variant, Result As Range)
ActiveSheet.Range("$A$13:$O$3057").AutoFilter Field:=6
If Not Columns(6).Find(what:=crit) Is Nothing Then
ActiveSheet.Range("$F$9:$F$3500").AutoFilter Field:=6, Criteria1:=crit
q = Application.WorksheetFunction.Subtotal(3, Range(Cells(9, 6), Cells(Cells(Rows.Count, 6).End(xlUp).Row, 6)))
Result = q
Else
q = 0
End If
MsgBox q
End Sub

Sub Итог()
    Application.ScreenUpdating = False
    Call OneFilter(Cells(4, 2).Text, Cells(4, 3))
    Call OneFilter(Cells(5, 2).Text, Cells(5, 3))
    Call OneFilter(Cells(6, 2).Text, Cells(6, 3))
    Call OneFilter(Cells(7, 2).Text, Cells(7, 3))
    Call OneFilter(Cells(8, 2).Text, Cells(8, 3))
    Call OneFilter(Cells(9, 2).Text, Cells(9, 3))
    Application.ScreenUpdating = True
End Sub