=ПСТР(A1;3;2)
=ЗНАЧЕН(ПСТР(A1;3;2))

Sub Макрос1()
    Dim ii As Long
    For ii = 1 To 100
        ActiveSheet.Copy After:=Sheets(Sheets.Count)
    Next
End Sub

=(ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;6)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6))/((ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;2)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2)))*(N4-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2))+ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6)

=(ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;6)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6))/((ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1)+1;2)-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2)))*(N4-ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);2))+ИНДЕКС(A1:K97; ПОИСКПОЗ(N4;B1:B97;1);6)

O5:O20    =O4+(СЧЁТЕСЛИМН(C$3:C4;C5;E$3:E4;E5;G$3:G4;G5;I$3:I4;I5)=0)

O5:O20    =O4+(СЧЁТЕСЛИМН(C$3:C4;C5;E$3:E4;E5;G$3:G4;G5;I$3:I4;I5)=0)
B24:C39    =ЕСЛИОШИБКА(ИНДЕКС(СМЕЩ($A$5:$A$20;0;ПОИСКПОЗ($23:$23;$4:$4;0)-1);ПОИСКПОЗ($A:$A;$O$5:$O$20;0));"")
E24:G39    =ЕСЛИОШИБКА(ИНДЕКС(СМЕЩ($A$5:$A$20;0;ПОИСКПОЗ($23:$23;$4:$4;0)-1);ПОИСКПОЗ($A:$A;$O$5:$O$20;0));"")
H24:H39    =СУММЕСЛИМН($L$5:$L$20;$C$5:$C$20;$C$23:$C$39;$E$5:$E$20;$E$23:$E$39;$G$5:$G$20;$F$23:$F$39;$I$5:$I$20;$G$23:$G$39)

="@"&ПОДСТАВИТЬ(F1;СИМВОЛ(10);"@"&СИМВОЛ(10)&"@")&"@"

=ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($E2;ПОИСК(":";$E2)-1));ПРАВСИМВ($E2;ДЛСТР($E2)-ПОИСК(":";$E2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($F2;ПОИСК(":";$F2)-1));ПРАВСИМВ($F2;ДЛСТР($F2)-ПОИСК(":";$F2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($G2;ПОИСК(":";$G2)-1));ПРАВСИМВ($G2;ДЛСТР($G2)-ПОИСК(":";$G2));"");"")&
ЕСЛИОШИБКА(ЕСЛИ(СОВПАД(A$1;ЛЕВСИМВ($H2;ПОИСК(":";$H2)-1));ПРАВСИМВ($H2;ДЛСТР($H2)-ПОИСК(":";$H2));"");"")

Sub DeleteEmptyRows()
    CloseEmptyWb
    ActiveSheet.Copy
    
    Dim rSelect As Range
    Set rSelect = Intersect(Selection, ActiveSheet.UsedRange)
    
    Dim rEntRow As Range
    Set rEntRow = Intersect(rSelect.EntireRow, ActiveSheet.UsedRange)
    
    Dim aSelect As Variant
    Dim aEntRow As Variant
    Dim oEntRow As Variant
    
    aSelect = GetArrayFromRange(rSelect)
    aEntRow = GetArrayFromRange(rEntRow)
    ReDim oEntRow(1 To UBound(aEntRow, 1), 1 To UBound(aEntRow, 2))
    
    Dim flag As Boolean
    Dim xa As Long
    Dim ya As Long
    Dim yo As Long
    For ya = 1 To UBound(aSelect, 1)
        flag = False
        For xa = 1 To UBound(aSelect, 2)
            If Not IsEmpty(aSelect(ya, xa)) Then
                flag = True
                Exit For
            End If
        Next
        If flag Then
            yo = yo + 1
            For xa = 1 To UBound(aEntRow, 2)
                oEntRow(yo, xa) = aEntRow(ya, xa)
            Next
        End If
    Next
    rEntRow = oEntRow
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    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

=РАБДЕНЬ(B2;1;$A$2:$A$26)

=РАБДЕНЬ_ПЛЮСПРАЗД(B2;1;$A$2:$A$26;$D$2:$D$26)

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

=РАБДЕНЬ_ПЛЮСПРАЗД(A2;5;$F$6:$F$9;$F$11)

=ЕСЛИ(ОСТАТ(СТОЛБЕЦ()-СТОЛБЕЦ($I$1)-МЕСЯЦ($D5)+1;12)=0;3;
ЕСЛИ(ОСТАТ(СТОЛБЕЦ()-СТОЛБЕЦ($I$1)-МЕСЯЦ($D5)+1;6)=0;2;
ЕСЛИ(ОСТАТ(СТОЛБЕЦ()-СТОЛБЕЦ($I$1)-МЕСЯЦ($D5)+1;1)=0;1;0)))

Sub AddSumRows()
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    CloseEmptyWb
    ActiveSheet.Copy
    AddSumRows_sheet ActiveSheet
    
    Application.Calculation = Application_Calculation
End Sub

Private Sub AddSumRows_sheet(sh As Worksheet)
    Dim xa As Long
    xa = GetCashNumberColumn(sh)
    With sh
        Dim ya As Long
        ya = .Cells(.Rows.Count, xa).End(xlUp).Row
        
        If ya = 1 Then
            CloseEmptyWb
            Exit Sub
        End If
        Dim arr As Variant
        arr = .Cells(1, xa).Resize(ya).Value
    End With

    AddSumRows_Array arr, sh, xa
End Sub

Private Function GetCashNumberColumn(sh As Worksheet) As Long
    Dim xx As Long
    On Error Resume Next
    xx = sh.UsedRange.Find("№ кассового документа").Column
    On Error GoTo 0
    If xx = 0 Then xx = [G1].Column
    
    GetCashNumberColumn = xx
End Function

Private Sub AddSumRows_Array(arr As Variant, sh As Worksheet, xa As Long)
    Dim yb As Long
    Dim ya As Long
    For ya = UBound(arr, 1) To 1 Step -1
        For yb = ya - 1 To 1 Step -1
            If arr(yb, 1) <> arr(ya, 1) Then
                Exit For
            End If
        Next
        yb = yb + 1
        If yb < ya Then
            AddSumRows_Row sh, ya + 1, xa, arr(ya, 1), ya - yb + 1
            ya = yb
        End If
    Next
End Sub

Private Sub AddSumRows_Row(sh As Worksheet, ya As Long, xa As Long, vVal As Variant, yd As Long)
    With sh
        .Rows(ya).Insert
        .Cells(ya, 1).Resize(1, xa - 1).Merge
        .Cells(ya, 1).Value = "Итого: "
        .Cells(ya, xa).Resize(1, 2).Merge
        .Cells(ya, xa).Value = vVal
        .Cells(ya, xa + 2).FormulaR1C1 = "=SUM(R[-1]C:R[-" & yd & "]C)"
        .Cells(ya, 1).Resize(1, xa + 2).Font.Bold = True
    End With
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

'v2
Sub myFormat()
    FormatSheet ActiveSheet
End Sub

Private Sub FormatSheet(sh As Worksheet)
    JobName sh, "Статус", True, False
    JobName sh, "Подразделение", False, True
End Sub

Private Sub JobName(sh As Worksheet, ByVal sName As String, blueMode As Boolean, boldMode As Boolean)
    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)
                Set cl = Intersect(cl.EntireRow, .UsedRange)
                If blueMode Then
                    Select Case arr(ya, 1)
                    Case "", "ПК"
                        cl.Font.Color = RGB(0, 0, 0)
                    Case Else
                        cl.Font.Color = RGB(51, 153, 255)
                    End Select
                End If
                
                If boldMode Then
                    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
            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 Macro3()

    Sheets("Sheet1").Range("E4:R4").Copy
    If Sheets("copy").Range("B5") = "" Then
        Sheets("copy").Range("B5").PasteSpecial Paste:=xlPasteValues
    Else
        Dim rID As Range
        On Error Resume Next
        Set rID = Sheets("copy").Range("B:C").Find(What:=Sheets("Sheet1").Range("E4"))
        On Error GoTo 0
        If rID Is Nothing Then
            LR = Sheets("copy").Range("B:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1
            Sheets("copy").Range("B" & LR).PasteSpecial Paste:=xlPasteValues
        Else
            rID.PasteSpecial Paste:=xlPasteValues
        End If
    End If
    Application.CutCopyMode = False
    MsgBox "Данные скопированы!", 64, "Info"
 
End Sub
  

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")