Private Sub Workbook_Open()
    Dim D As Date                       'переменная Дата - условие
    Dim sh As Worksheet                 'объектная переменная Лист Excel
    Dim nam$                            'строковая переменная - имя листа с датой
    
    nam = "Служ"                        'задаем имя листа с датой
    With Me                             'работаем с книгой, из которой запускается этот макрос
        D = .Sheets(nam).[Z3]           'пишем дату с листа в переменную
        If Date >= D Then               'если текущая системная дата >= условие
            For Each sh In .Sheets      'перебор всех листов
                If sh.Name <> nam Then  'если имя листа <> значению переменной nam
                    sh.Columns.Delete   'удаляем всё с листа
                End If
            Next
        End If
    End With
End Sub

Sub Copfyiles()
    Const sPath1$ = "d:\layout\"
    Dim S$, sPath2$, sFrom$, sTo$
    Dim cell As Range, i%, j%
    sPath2 = CreateObject("Shell.Application").Namespace(0).self.path & "\" & [G2] & "\"
    If Dir(sPath2, 16) = "" Then MkDir sPath2
    On Error Resume Next
    With [A2].CurrentRegion
        For Each cell In .Offset(1, 1).SpecialCells(xlCellTypeConstants, 1).Cells
            S = Intersect(cell.EntireColumn, .Rows(1)) & "\" & Intersect(cell.EntireRow, .Columns(1)) & "\"
            sFrom = sPath1 & S
            sTo = sPath2 & Replace(S, "\", "_")
            For i = 1 To 5
                For j = 1 To cell
                    Select Case True
                        Case i < 3 Or (j = cell And j Mod 2)
                            FileCopy sFrom & i & ".tif", sTo & i & "-" & j & ".tif"
                        Case (j Mod 2) = 0
                            FileCopy sFrom & i * 11 & ".tif", sTo & i * 11 & "-" & j \ 2 & ".tif"
                    End Select
                Next
            Next
        Next
    End With
    If MsgBox("Готово!" & vbLf & "Открыть папку?", 36) = 6 Then Shell "explorer """ & sPath2 & """", 1
End Sub

Private Sub UserForm_Initialize()
    With ActiveSheet
        Me.ListBox1.RowSource = .Range(.[A2], .Cells(.Rows.Count, "L").End(xlUp)).Address(0, 0, 1, 1)
    End With
End Sub

Sub Copfyiles()
    Const sPath1$ = "d:\layout\"
    Dim S$, sPath2$, sFrom$, sTo$
    Dim cell As Range, r As Range, i%, j%, n
    sPath2 = CreateObject("Shell.Application").Namespace(0).self.path & "\" & [G2] & "\"
    If Dir(sPath2, 16) = "" Then MkDir sPath2
    On Error Resume Next
    With [A2].CurrentRegion
        With .Offset(1, 1)
            Set r = .SpecialCells(xlCellTypeFormulas, 1)
            If r Is Nothing Then
                Set r = .SpecialCells(xlCellTypeConstants, 1)
            Else
                Set r = Union(r, .SpecialCells(xlCellTypeConstants, 1))
            End If
            If r Is Nothing Then Exit Sub
        End With
        For Each cell In r.Cells
            S = Intersect(cell.EntireColumn, .Rows(1)) & "\" & Intersect(cell.EntireRow, .Columns(1)) & "\"
            sFrom = sPath1 & S
            sTo = sPath2 & Replace(S, "\", "_")
            For i = 1 To 5
                For j = 1 To cell
                    Select Case True
                        Case i < 3 Or (j = cell And j Mod 2)
                            FileCopy sFrom & i & ".tif", sTo & i & "-" & j & ".tif"
                        Case (j Mod 2) = 0
                            FileCopy sFrom & i * 11 & ".tif", sTo & i * 11 & "-" & j \ 2 & ".tif"
                    End Select
                Next
            Next
        Next
    End With
    Set r = Nothing
    If MsgBox("Готово!" & vbLf & "Открыть папку?", 36) = 6 Then Shell "explorer """ & sPath2 & """", 1
End Sub

=ОТБР((B2-ОКРВВЕРХ(B1-B3-1;7)-B3-1)/7)-СУММПРОИЗВ((F2:F10>=B1)*(F2:F10<=B2)*(ДЕНЬНЕД(F2:F10;2)=B3))

Sub dd()
    With Application
    .ScreenUpdating = 0: .EnableEvents = 0: .DisplayAlerts = 0
    With Sheets("Ëèñò1")
        .Copy Sheets(1)
        With .[A1].CurrentRegion
            .UnMerge
            On Error Resume Next
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
            On Error GoTo 0
            Sheets(1).Range(.Address).Copy
            .PasteSpecial xlPasteFormats
            Sheets(1).Delete
        End With
    End With
    .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1
    End With
End Sub

=--СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ($A1;"+";ПОВТОР(" ";99));(СТОЛБЕЦ(A1)-1)*99+2;99))

=МИН(МАКС(ПРОСМОТР(H2%%;{0;2;10;20;100};{0;2;8;13;33}*400)+(H2%%-ПРОСМОТР(H2%%;{0;2;10;20;100}))/1%*ПРОСМОТР(H2%%;{0;2;10;20;100};{4;3;2;1;0,5});400);60000)/2

=ОКРУГЛ(МИН(МАКС(ПРОСМОТР(H2%%;{0;2;10;20;100};{0;2;8;13;33}*400)+(H2%%-ПРОСМОТР(H2%%;{0;2;10;20;100}))/1%*ПРОСМОТР(H2%%;{0;2;10;20;100};{4;3;2;1;0,5});400);60000)/2;0)

=ЕСЛИ(G5<"";СЧЁТ(1/ЧАСТОТА(ЕСЛИ((G$6:G$77<=G5)*(G$6:G$77>0);G$6:G$77);G$6:G$77));"")

=ЕСЛИ(G5<"";СЧЁТ(1/ЧАСТОТА(ЕСЛИ((G$5:G$77<=G5)*(G$5:G$77>0);G$5:G$77);G$5:G$77));"")

=ОТБР((B2-ОКРВВЕРХ(B1-B3-8;7)-B3-1)/7)-СУММПРОИЗВ((F2:F10>=B1)*(F2:F10<=B2)*(ДЕНЬНЕД(F2:F10;2)=B3))

=ОТБР((B2-ОКРВНИЗ(С-B3-1;7)-B3-1)/7)-СУММПРОИЗВ((F2:F10>=B1)*(F2:F10<=B2)*(ДЕНЬНЕД(F2:F10;2)=B3))

С    =Лист1!$B$1

По    =Лист1!$B$2

ДН    =Лист1!$B$3

Д1    =ДН+1

Д2    =ОКРВНИЗ(С-Д1;7)+Д1

КДН    =ОТБР((ПО-Д2)/7)

=ОТБР((B2-ОКРВНИЗ(B1-B3-1;7)-B3-1)/7)

Sub vvv()
    With Selection
        .Replace "Автомобиль", "=xx1", xlWhole
        Intersect([xx1].Dependents, .Cells).Delete xlUp
        With .SpecialCells(xlCellTypeConstants, 1)
            Set r = .Find("?", , xlValues, xlWhole, Searchformat:=False)
            Do While Not r Is Nothing
                r.Formula = Format(r, "'00")
                Set r = .FindNext(r)
            Loop
        End With
    End With
End Sub

=ОТБР((B2-ОКРВНИЗ(B1-B3-1;7)-B3-1)/7)-СЧЁТ(1/(ДЕНЬНЕД(ТЕКСТ(ТЕКСТ({43101:43102:43103:43104:43105:43106:43107:43108:43154:43167:43168:43220:43221:43222:43229:43262:43263:43409:43465};"[>="&B1&"]0;");"[<="&B2&"]0;"))=B3))

=ЕСЛИОШИБКА(ПРОСМОТР(;-1/ЕНД(ПОИСКПОЗ($C$5:ИНДЕКС(C:C;ПОИСКПОЗ("яяя";$C$1:$C$77));$K$4:K4;));$C$5:$C$77);"")

Sub Макрос1()
    Application.ScreenUpdating = False
    Dim sh As Shape
    On Error Resume Next
    Set sh = ActiveSheet.Shapes("Вставленный")
    Do Until sh Is Nothing
        sh.Delete
        Set sh = Nothing
        Set sh = ActiveSheet.Shapes("Вставленный")
    Loop
End Sub

Sub vvv()
    Dim v As Variant
    On Error Resume Next
    With Selection
        For Each v In Array("авто*", "Метла", "61??", ChrW(157))
            .Replace v, "=xfd1", xlWhole, searchformat:=False
            Intersect([xfd1].Dependents, .Cells).Delete xlUp
        Next
    End With
End Sub