Sub myFormat()
    FormatSheet ActiveSheet
End Sub

Private Sub FormatSheet(sh As Worksheet)
    Dim vName As Variant
    For Each vName In Array("Статус", "Подразделение")
        JobName vName, sh
    Next
End Sub

Private Sub JobName(ByVal sName As String, sh As Worksheet)
    Dim rn As Range
    Set rn = GetNameRange(sName, sh)
    If rn Is Nothing Then Exit Sub
    
    With sh
        Dim arr As Variant
        arr = .Range(.Cells(1, rn.Column), .Cells(.UsedRange.Row + .UsedRange.Rows.Count, rn.Column))
        
        Dim cl As Range
        Dim ya As Long
        For ya = rn.MergeArea.Row + rn.MergeArea.Rows.Count To UBound(arr, 1) - 1
            If Not IsError(arr(ya, 1)) Then
                Set cl = .Cells(ya, rn.Column)
                
                Select Case arr(ya, 1)
                Case "", "ПК"
                    cl.Font.Color = RGB(0, 0, 0)
                Case Else
                    cl.Font.Color = RGB(51, 153, 255)
                End Select
                
                If arr(ya, 1) <> arr(ya + 1, 1) Then
                    With cl.Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .ColorIndex = xlAutomatic
                        .TintAndShade = 0
                        .Weight = xlMedium
                    End With
                Else
                    With cl.Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .ColorIndex = xlAutomatic
                        .TintAndShade = 0
                        .Weight = xlThin
                    End With
                End If
            End If
        Next
    End With
End Sub

Private Function GetNameRange(sName As String, sh As Worksheet) As Range
    Dim yr As Long
    Dim xr As Long
    
    On Error Resume Next
    With sh
        For yr = .UsedRange.Row To .UsedRange.Row + .UsedRange.Rows.Count - 1
            xr = WorksheetFunction.Match(sName, .Rows(yr), 0)
            If xr > 0 Then
                Set GetNameRange = .Cells(yr, xr)
                Exit For
            End If
        Next
    End With
    On Error GoTo 0
End Function

Sub InsertRows_ActiveSheet()
    InsertRows_Sheet ActiveSheet
End Sub

Private Sub InsertRows_Sheet(sh As Worksheet)
    Const xx = 1
    With sh
        Dim ya As Long
        ya = .Cells(.Rows.Count, xx).End(xlUp).Row
        
        Dim rr As Range
        Set rr = .Range(.Cells(.UsedRange.Row, xx), .Cells(ya, xx))
        Dim arr As Variant
        arr = GetArrayFromRange(rr)
        For ya = UBound(arr, 1) To 1 Step -1
            If Not IsError(arr(ya, 1)) Then
                If IsNumeric(arr(ya, 1)) Then
                    If arr(ya, 1) > 0 Then
                        rr.Cells(ya + 1, 1).EntireRow.Resize(arr(ya, 1)).Insert
                    End If
                End If
            End If
        Next
    End With
End Sub

Private Function GetArrayFromRange(rr As Range) As Variant
    Dim arr As Variant
    If rr.Cells.CountLarge = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    GetArrayFromRange = arr
End Function

Sub myTransform()
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
        
    Dim sh As Worksheet
    For Each sh In ThisWorkbook.Worksheets
        If GoodSheet(sh) Then
            JobSheet sh
        End If
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub JobSheet(sh As Worksheet)
    Dim rr As Range
    On Error Resume Next
    Set rr = sh.Cells.SpecialCells(xlCellTypeConstants, 2)
    On Error GoTo 0
    If Not rr Is Nothing Then JobRange rr
End Sub

Private Sub JobRange(rr As Range)
    Dim rArea As Range
    For Each rArea In rr.Areas
        JobArea rArea
    Next
End Sub

Private Sub JobArea(rr As Range)
    Dim arr As Variant
    arr = GetArrayFromRange(rr)
    JobArray arr, rr
    rr.Value = arr
End Sub

Private Sub JobArray(arr As Variant, rr As Range)
    Dim ya As Long
    Dim xa As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            If Not IsError(arr(ya, xa)) Then
                If arr(ya, xa) <> "" Then
                    If IsNumeric(arr(ya, xa)) Then
                        arr(ya, xa) = CDbl(arr(ya, xa))
                        If Len(arr(ya, xa)) > 10 Then
                            rr.Cells(ya, xa).NumberFormat = "0"
                        Else
                            rr.Cells(ya, xa).NumberFormat = "General"
                        End If
                    End If
                End If
            End If
        Next
    Next
End Sub
Private Function GetArrayFromRange(rr As Range) As Variant
    Dim arr As Variant
    If rr.Cells.CountLarge = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    GetArrayFromRange = arr
End Function

Private Function GoodSheet(sh As Worksheet) As Boolean
    Select Case sh.Name
    Case "Парадная"
    Case Else
        GoodSheet = True
    End Select
End Function

Sub CommandButton1_Click()
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual

    Dim col As Variant
    For Each col In Array(4, 6, 8, 9, 10)
        ColumnJob Columns(col)
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub ColumnJob(col As Range)
    Set col = Intersect(col, col.Parent.UsedRange)
    If col.Cells.CountLarge = 1 Then Exit Sub
    
    Dim arr As Variant
    arr = col.Value
    
    Dim hasDate As Boolean
    Dim hasDecimal As Boolean
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If Not IsError(arr(ya, 1)) Then
            If arr(ya, 1) <> "" Then
                If IsDate(arr(ya, 1)) Then
                    arr(ya, 1) = CDate(arr(ya, 1))
                    hasDate = True
                    If arr(ya, 1) - CLng(arr(ya, 1)) <> 0 Then hasDecimal = True
                End If
            End If
        End If
    Next
    
    With col.Cells(2, 1).Resize(col.Rows.Count - 1)
        If hasDecimal Then
            .NumberFormat = "dd.mm.yyyy hh:mm"
        ElseIf hasDate Then
            .NumberFormat = "dd.mm.yyyy"
        End If
    End With
    If hasDate Then
        col.Value = arr
        col.EntireColumn.AutoFit
    End If
End Sub

L2    =ВПР(B:B;P:R;3;0)
R2    =ЕСЛИОШИБКА(ВПР(P2;P3:$R$31;3;0);0)+1*(СЧЁТЕСЛИМН(P2:$P$31;P2;Q2:$Q$31;Q2)=1)

Sub Task2()
    Dim A As Range: Set A = Range("B8")
    Dim B As Range: Set B = Range("B9")
    Dim V As Range: Set V = Range("B11")
    Dim T As Range: Set T = Range("C6")
    
    Dim maxV As Double
    Dim maxA As Long
    Dim maxB As Long
    Dim minT As Double
    
    Application.Calculation = xlCalculationAutomatic
    
    A = 0
    B = 0
    Do
        Do
            If bExit Then Exit Do
            If maxV < V Then
                maxV = V
                maxA = A
                maxB = B
                minT = T
            ElseIf maxV = V Then
                If minT > T Then
                    maxA = A
                    maxB = B
                    minT = T
                End If
            End If
            
            B = B + 1
        Loop
        B = 0
        A = A + 1
        If bExit Then Exit Do
    Loop
    
    A = maxA
    B = maxB
End Sub

Private Function bExit() As Boolean
    If Range("B5") < Range("C5") Then bExit = True
    If Range("B6") < Range("C6") Then bExit = True
End Function

=СЧЁТЕСЛИМН($A$1:$A$4;"*монитор*";$B$1:$B$4;">80";$B$1:$B$4;"<100")

=И($S22>=$Q22;$S22>=$P22)

Function ConcatUniq(xRg As Range, xChar As String) As String
    Dim xCell As Range
    Dim xDic As Object
    Set xDic = CreateObject("Scripting.Dictionary")
    For Each xCell In xRg
        If xCell.Value <> 1 Then xDic(xCell.Value) = Empty
    Next
    ConcatUniq = Join$(xDic.Keys, xChar)
    Set xDic = Nothing
End Function

'v2
Sub WayBill_print()
Dim iBt$
Dim arrHD()
Dim iMark$, iNum$, iFIO$, iCount&
On Error Resume Next
'получаем имя нажатой кнопки
iBt = Application.Caller 'это самая важная строка) если изменить имена кнопок - макрос сломается!
'проверяем - если при нажатии не возникло ошибки, то продолжаем макрос
If Err = 0 And iBt <> Empty Then
  With Worksheets("Глав")
    'исходя из полученного имени кнопки присваиваем переменным значения из соответствующих ячеек
    Select Case iBt
      'если нажата одна из кнопок напротив 1 машины
      Case "BT1-one", "BT1-many"
        'марка машины
        iMark = .Range("D2").Text
        'номер машины
        iNum = .Range("D3").Text
        'ФИО водителя
        iFIO = .Range("C4").Text
      'если нажата одна из кнопок 2 машины
      Case "BT2-one", "BT2-many"
        'тут аналогично, только данные из соответствующих ячеек
        iMark = .Range("D5").Text
        iNum = .Range("D6").Text
        iFIO = .Range("C7").Text
    End Select
    'опять же, в зависимрсти от имени кнопки, назначаем количество раз для печати
    If iBt = "BT1-one" Or iBt = "BT2-one" Then
      'один раз для печати только следующего рабочего дня
      iCount = 1
    Else
      'тут количество берется из ячеек, для многократной печати
      iCount = IIf(iBt = "BT1-many", .Range("P3"), .Range("P6"))
    End If
  End With
  With Worksheets("Лист1")
    'вставляем значения переменных в поля Путевого листа
    .Range("D5") = iMark: .Range("D6") = iNum: .Range("D7") = iFIO
    'начинаем цикл печати от 1 до нужного количества раз
    Dim I As Long
    For I = 1 To iCount
      'при этом, кажды проход цикла, вставляем в путевой лист дату следующего рабочего дня
      'используя функцию листа РАБДЕНЬ в варианте ее применения в VBA
      '.Range("D3") = Application.WorksheetFunction.WorkDay(Date, I, Worksheets("Глав").Range("V2:V29"))
      .Range("D3") = РАБДЕНЬ_ПЛЮСПРАЗД(Date, I, Worksheets("Глав").Range("V2:V29"), Worksheets("Глав").Range("W2:W29"))
      'эта строка выводит путевой лист на печать, на принтер, установленный по умолчанию
      .PrintOut 'Preview:=True 'это аргумент предпросмотра (сейчас отключен)
    Next
  End With
End If
End Sub

Function РАБДЕНЬ_ПЛЮСПРАЗД(нач_дата As Date, число_дней As Long, праздники As Range, рабочие_выходные As Range) As Date
    Dim flag As Boolean
    Dim dt As Date
    Dim ii As Long
    dt = нач_дата
    Do
        If ii >= число_дней Then Exit Do
        dt = dt + 1
        If WorksheetFunction.CountIfs(праздники, dt) > 0 Then
            flag = False
        ElseIf WorksheetFunction.CountIfs(рабочие_выходные, dt) > 0 Then
            flag = True
        ElseIf WorksheetFunction.Weekday(dt, 2) > 5 Then
            flag = False
        Else
            flag = True
        End If
        If flag Then ii = ii + 1
    Loop
    РАБДЕНЬ_ПЛЮСПРАЗД = dt
End Function

'v2
Sub LongStringSort()
    Dim rTarg As Range
    Set rTarg = Selection
    'Set rTarg = rTarg.Columns(1)
    Set rTarg = Intersect(rTarg, rTarg.Parent.UsedRange)
    Set rTarg = rTarg.Areas(1)
    If rTarg.Cells.CountLarge = 1 Then Exit Sub
    
    Dim rSort As Range
    On Error Resume Next
    Set rSort = Application.InputBox("Введите столбец сортировки", "Сортировка", rTarg.Columns(1).EntireColumn.Address(0, 0, xlA1), Type:=8)
    On Error GoTo 0
    If rSort Is Nothing Then Exit Sub
    If Intersect(rSort, rTarg) Is Nothing Then Exit Sub
    
    Dim xSort As Long
    xSort = rSort.Column - rTarg.Column + 1
    If xSort < 0 Then Exit Sub
    
    Dim arr As Variant
    arr = rTarg.Value
    ClearArray arr
    arr = GetSortArray(arr, xSort)
    If IsEmpty(arr) Then Exit Sub
    rTarg.Value = arr
End Sub

Private Function GetSortArray(arr As Variant, xSort As Long) As Variant
    Dim sortBeg As Long
    Dim sortFin As Long
    Dim mrr As Variant
    mrr = GetMultiColumnArray(arr, xSort, sortBeg, sortFin)
    If IsEmpty(mrr) Then Exit Function
    If sortBeg < 1 Then Exit Function
    If sortFin < sortBeg Then Exit Function
    
    With Workbooks.Add(1)
        With .Sheets(1)
            Dim rr As Range
            Set rr = .Cells(1, 1).Resize(UBound(mrr, 1), UBound(mrr, 2))
            rr.Value = mrr
            With .Sort
                .SortFields.Clear
                Dim xr As Long
                For xr = sortBeg To sortFin
                    .SortFields.Add Key:=rr.Columns(xr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                Next
                .SetRange rr
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            mrr = rr.Value
        End With
        .Close False
    End With
    
    Dim orr As Variant
    orr = GetOneColumnArray(mrr, sortBeg, sortFin)
    
    GetSortArray = orr
End Function

Private Function GetOneColumnArray(arr As Variant, sortBeg As Long, sortFin As Long) As Variant
     Dim orr As Variant
     ReDim orr(1 To UBound(arr, 1), 1 To UBound(arr, 2) - (sortFin - sortBeg))
     
     Dim ya As Long
     Dim xa As Long
     Dim xo As Long
     Dim ss As String
     For ya = 1 To UBound(arr, 1)
        For xa = 1 To sortBeg - 1
            orr(ya, xa) = arr(ya, xa)
        Next
        xo = UBound(orr, 2)
        For xa = UBound(arr, 2) To sortFin + 1 Step -1
            orr(ya, xo) = arr(ya, xa)
            xo = xo - 1
        Next
        
        ss = ""
        For xa = sortBeg To sortFin
            ss = ss & arr(ya, xa)
        Next
        orr(ya, sortBeg) = ss
     Next
     
     GetOneColumnArray = orr
End Function

Private Function GetMultiColumnArray(arr As Variant, xSort As Long, sortBeg As Long, sortFin As Long) As Variant
    Const nStep = 255

    Dim nx As Long
    nx = GetColumnNumbers(arr, xSort, nStep)
    If nx = 0 Then Exit Function
    
    sortBeg = xSort
    sortFin = sortBeg + nx - 1
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2) + nx - 1)
    
    Dim ss As String
    Dim iPart As Long
    Dim xb As Long
    Dim xa As Long
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        For xb = 1 To xSort - 1
            brr(ya, xb) = arr(ya, xb)
        Next
        
        xb = UBound(brr, 2)
        For xa = UBound(arr, 2) To xSort + 1 Step -1
            brr(ya, xb) = arr(ya, xa)
            xb = xb - 1
        Next

        If arr(ya, xSort) <> "" Then
           xb = xSort
           iPart = 0
           Do
               ss = Mid(arr(ya, xSort), 1 + iPart * nStep, nStep)
               If ss = "" Then Exit Do
               brr(ya, xb) = ss
               xb = xb + 1
               iPart = iPart + 1
           Loop
        End If
    Next
    
    GetMultiColumnArray = brr
End Function

Private Function GetColumnNumbers(arr As Variant, xSort As Long, nn As Long) As Long
    Dim ni As Long
    Dim nMax As Long
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If arr(ya, xSort) <> "" Then
            ni = Len(arr(ya, xSort)) \ nn + 1
            If nMax < ni Then nMax = ni
        End If
    Next
    GetColumnNumbers = nMax
End Function

Private Sub ClearArray(arr As Variant)
    Dim ya As Long
    Dim xa As Long
    For ya = LBound(arr, 1) To UBound(arr, 1)
        For xa = LBound(arr, 2) To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then
                arr(ya, xa) = Empty
            End If
        Next
    Next
End Sub

Sub Rename_File()
    Dim sFilePath As String, LastRow As Long, Cell As Range
    sFilePath = Split(Range("A1").Text, " ", 3)(2)    'путь к текущей паке
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\"
    
    If Application.WorksheetFunction.CountA(Range("A3:A" & LastRow)) <> Application.WorksheetFunction.CountA(Range("B3:B" & LastRow)) Then Exit Sub
    
    For Each Cell In Range("A3:A" & LastRow)
        If Dir(sFilePath & Cell.Text, 16) <> "" And ThisWorkbook.FullName <> sFilePath & Cell.Text Then
            Name sFilePath & Cell.Text As GetNewName(sFilePath, Cell.Offset(0, 1).Text) 'переименовываем файл
        End If
    Next Cell
    'Update file list
    Call ListFilesInFolder(sFilePath)
    Shell "explorer.exe " & sFilePath, vbNormalFocus
End Sub

Private Function GetNewName(sFilePath As String, sName As String) As String
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim sBase As String
    sBase = fso.GetBaseName(sName)
    Dim sExte As String
    sExte = "." & fso.GetExtensionName(sName)
    Dim sFull As String
    Dim sIndx As String
    Dim ii As Long
    
    Do
        If ii = 0 Then
            sIndx = ""
        Else
            sIndx = "(" & ii & ")"
        End If
        sFull = sFilePath & sBase & sIndx & sExte
        If Dir(sFull, 16) = "" Then Exit Do
                
        ii = ii + 1
    Loop
    GetNewName = sFull
End Function

Sub LongStringSort()
    Dim rTarg As Range
    Set rTarg = Selection
    Set rTarg = rTarg.Columns(1)
    Set rTarg = Intersect(rTarg, rTarg.Parent.UsedRange)
    Set rTarg = rTarg.Areas(1)
    If rTarg.Cells.CountLarge = 1 Then Exit Sub
    
    Dim arr As Variant
    arr = rTarg.Value
    ClearArray arr
    arr = GetSortArray(arr)
    If IsEmpty(arr) Then Exit Sub
    rTarg.Value = arr
End Sub

Private Function GetSortArray(arr As Variant) As Variant
    Dim mrr As Variant
    mrr = GetMultiColumnArray(arr)
    If IsEmpty(mrr) Then Exit Function
    
    With Workbooks.Add(1)
        With .Sheets(1)
            Dim rr As Range
            Set rr = .Cells(1, 1).Resize(UBound(mrr, 1), UBound(mrr, 2))
            rr.Value = mrr
            With .Sort
                .SortFields.Clear
                Dim xr As Long
                For xr = 1 To rr.Columns.Count
                    .SortFields.Add Key:=rr.Columns(xr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                Next
                .SetRange rr
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            mrr = rr.Value
        End With
        .Close False
    End With
    
    Dim orr As Variant
    orr = GetOneColumnArray(mrr)
    
    GetSortArray = orr
End Function

Private Function GetOneColumnArray(arr As Variant) As Variant
     Dim orr As Variant
     ReDim orr(1 To UBound(arr, 1), 1 To 1)
     
     Dim ya As Long
     Dim xa As Long
     Dim ss As String
     For ya = 1 To UBound(arr, 1)
        ss = ""
        For xa = 1 To UBound(arr, 2)
            ss = ss & arr(ya, xa)
        Next
        orr(ya, 1) = ss
     Next
     
     GetOneColumnArray = orr
End Function

Private Function GetMultiColumnArray(arr As Variant) As Variant
    Const nStep = 255

    Dim nx As Long
    nx = GetColumnNumbers(arr, nStep)
    If nx = 0 Then Exit Function
    
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To nx)
    
    Dim ss As String
    Dim xb As Long
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
         If arr(ya, 1) <> "" Then
            xb = 1
            Do
                ss = Mid(arr(ya, 1), 1 + (xb - 1) * nStep, nStep)
                If ss = "" Then Exit Do
                brr(ya, xb) = ss
                xb = xb + 1
            Loop
         End If
    Next
    
    GetMultiColumnArray = brr
End Function

Private Function GetColumnNumbers(arr As Variant, nn As Long) As Long
    Dim ni As Long
    Dim nMax As Long
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If arr(ya, 1) <> "" Then
            ni = Len(arr(ya, 1)) \ nn + 1
            If nMax < ni Then nMax = ni
        End If
    Next
    GetColumnNumbers = nMax
End Function

Private Sub ClearArray(arr As Variant)
    Dim ya As Long
    Dim xa As Long
    For ya = LBound(arr, 1) To UBound(arr, 1)
        For xa = LBound(arr, 2) To UBound(arr, 2)
            If IsError(arr(ya, xa)) Then
                arr(ya, xa) = Empty
            End If
        Next
    Next
End Sub

=ЕСЛИ((100000-МАКС(('партии кол-во и срок'!$C$2:$C$29=A2)*(100000-'партии кол-во и срок'!$J$2:$J$29)))>($F$1+30);"да";"нет")

=ЕСЛИ((1000-МАКС(('партии кол-во и срок'!$C$2:$C$29=A2)*(1000-'партии кол-во и срок'!$G$2:$G$29)))>40;"да";"нет")

=ЕСЛИ((ДЛСТР(A2)=8)*(СЧЁТЕСЛИМН('партии кол-во и срок'!C:C;A2)=4);"да";"нет")

Private Const myColumn = "E"

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Column <> Range(myColumn & 1).Column Then Exit Sub
            
    On Error Resume Next
    Dim dValue As Double
    dValue = Target.Value
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Undo
    Target.Value = Target.Value + dValue
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    On Error GoTo 0
End Sub

=(ЛЕВСИМВ(A2;4)="I60.")+(ЛЕВСИМВ(A2;4)="I61.")+(ЛЕВСИМВ(A2;4)="I62.")+(ЛЕВСИМВ(A2;4)="I63.")+(ЛЕВСИМВ(A2;4)="I64.")