=ЕСЛИ(S31="";"";ЕСЛИ(S32<S31+ЗНАЧЕН(S25);S31+ЗНАЧЕН(S25)-S32;""))

'v2
Sub FillSelection()
    Dim ru As Range
    Set ru = Intersect(Selection, ActiveSheet.UsedRange)
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim xa As Long
    Dim ya As Long
    Dim arr As Variant
    Dim iIndex As Long
    Dim sKey As String
    Dim rArea As Range
    For Each rArea In ru.Areas
        If rArea.Rows.Count > 0 Then
            arr = rArea.Value
            
            For xa = 1 To UBound(arr, 2)
                sKey = arr(1, xa)
                iIndex = 1
                For ya = 2 To UBound(arr, 1)
                    If IsEmpty(arr(ya, xa)) Then
                        arr(ya, xa) = sKey & "_п" & iIndex
                        iIndex = iIndex + 1
                    Else
                        sKey = arr(ya, xa)
                        iIndex = 1
                    End If
                Next
            Next
            rArea.Value = arr
        End If
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Sub FillSelection()
    Dim ru As Range
    Set ru = Intersect(Selection, ActiveSheet.UsedRange)
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim ya As Long
    Dim arr As Variant
    Dim iIndex As Long
    Dim sKey As String
    Dim rArea As Range
    For Each rArea In ru.Areas
        If rArea.Rows.Count > 0 Then
            arr = rArea.Value
            
            sKey = arr(1, 1)
            iIndex = 1
            For ya = 2 To UBound(arr, 1)
                If IsEmpty(arr(ya, 1)) Then
                    arr(ya, 1) = sKey & "_п" & iIndex
                    iIndex = iIndex + 1
                Else
                    sKey = arr(ya, 1)
                    iIndex = 1
                End If
            Next
            rArea.Value = arr
        End If
    Next
    
    Application.Calculation = Application_Calculation
End Sub

=ЕСЛИ(ЕПУСТО(A2);ЕСЛИ(ЕОШ(НАЙТИ("_п";E1));E1&"_п1";ЛЕВСИМВ(E1;НАЙТИ("_п";E1)+1)&ЕСЛИОШИБКА(ЗНАЧЕН(ПСТР(E1;НАЙТИ("_п";E1)+2;ДЛСТР(E1)))+1;1));A2)

=ЕСЛИ(ЕПУСТО(A2);C1&ЕСЛИ(ЕОШ(НАЙТИ("_п";C1));"_п";"");A2)

Private Sub Fill(dic As Dictionary, sPref$)
    'dic.RemoveAll
    Set dic = New Dictionary

Option Explicit

Private Const xKey = 1 'Столбец ключа
Private Const xValue = 5 'Столбец значения

Sub myVLOOKUP()
    Dim file1 As String
    file1 = ThisWorkbook.Path & "\Первый.xlsx"

    Dim file2 As String
    file2 = ThisWorkbook.Path & "\Второй.xlsx"
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim dic As Object
    Set dic = GetDic(file1)
    If Not dic Is Nothing Then
        If dic.Count > 0 Then
            FillFromDic file2, dic
        End If
    End If
    Application.Calculation = Application_Calculation
End Sub

Private Sub FillFromDic(sFull As String, dic As Object)
    Dim wb As Workbook
    Set wb = GetWb(sFull, True)
    If wb Is Nothing Then Exit Sub
        
    FillSheet wb.Sheets(1), dic
End Sub

Private Sub FillSheet(sh As Worksheet, dic As Object)
    Const nStep = 10000
    Dim iStep As Long
    
    Dim krr As Variant
    Dim vrr As Variant
    
    
    With sh
        Dim yMax As Long
        yMax = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim ys As Long
        iStep = nStep
        For ys = 1 To yMax Step nStep
            
            If ys + nStep - 1 > yMax Then
                iStep = yMax - ys + 1
            End If
            
            krr = GetArrayFromRange(.Cells(ys, 1).Resize(iStep))
            ReDim vrr(1 To UBound(krr, 1), 1 To 1)
            
            FillValueArray dic, krr, vrr
            
            .Cells(ys, 2).Resize(UBound(vrr, 1)).Value = vrr
        Next
    End With
End Sub

Private Sub FillValueArray(dic As Object, krr As Variant, vrr As Variant)
    Dim aKey As Variant
    Dim yk As Long
    For yk = 1 To UBound(krr, 1)
        If krr(yk, 1) <> "" Then
            aKey = GetKeyArray(CStr(krr(yk, 1)))
                 
            On Error Resume Next
            vrr(yk, 1) = dic.Item(aKey(1)).Item(aKey(2)).Item(aKey(3)).Item(aKey(4)).Keys()(0)
            On Error GoTo 0
        End If
    Next
End Sub

Private Function GetDic(sFull As String) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim wb As Workbook
    Set wb = GetWb(sFull, True)
    If Not wb Is Nothing Then
        Dim sh As Worksheet
        For Each sh In wb.Worksheets
            FillDicFromSheet dic, sh
        Next
        If wb.ReadOnly Then wb.Close False
    End If
    
    Set GetDic = dic
End Function

Private Sub FillDicFromSheet(dic As Object, sh As Worksheet)
    Dim tb As ListObject
    For Each tb In sh.ListObjects
        FillDicFromListObject dic, tb
    Next
End Sub

Private Sub FillDicFromListObject(dic As Object, tb As ListObject)
    Const nStep = 10000
    Dim iStep As Long
    Dim krr As Variant
    Dim vrr As Variant
    Dim yt As Long
    iStep = nStep
    For yt = 1 To tb.DataBodyRange.Rows.Count Step nStep
        If yt + nStep - 1 > tb.DataBodyRange.Rows.Count Then
            iStep = tb.DataBodyRange.Rows.Count - yt + 1
        End If
    
        krr = GetArrayFromRange(tb.DataBodyRange.Cells(yt, xKey).Resize(iStep))
        vrr = GetArrayFromRange(tb.DataBodyRange.Cells(yt, xValue).Resize(iStep))
        
        FillDicFromArrays dic, krr, vrr
    Next
End Sub

Private Sub FillDicFromArrays(dic As Object, krr As Variant, vrr As Variant)
    Dim yk As Long
    For yk = 1 To UBound(krr, 1)
        If krr(yk, 1) <> "" Then
            AddDicItem dic, krr(yk, 1), vrr(yk, 1)
        End If
    Next
End Sub

Private Sub AddDicItem(dic As Object, ByVal sKey As String, vValue As Variant)
    
    Dim aKey As Variant
    aKey = GetKeyArray(sKey)
    
    ReDim Preserve aKey(LBound(aKey) To UBound(aKey) + 1)
    aKey(UBound(aKey)) = vValue
    
    DicAdd dic, aKey
End Sub

Private Function GetKeyArray(sKey As String) As Variant
    Dim longKey As String
    longKey = GetKey(sKey)
    
    Dim arr As Variant
    ReDim arr(1 To 4)
    Dim ya As Long
    For ya = LBound(arr) To UBound(arr) - 1
        arr(ya) = Mid(longKey, 1 + 4 * (ya - 1), 4)
    Next
    arr(ya) = Mid(longKey, 1 + 4 * (ya - 1), Len(longKey))
    
    GetKeyArray = arr
End Function

Private Function GetKey(ByVal sKey As String) As String
    Dim ss As String
    If Len(sKey) < 16 Then
        ss = sKey & String(15, "_")
        ss = Left(ss, 16)
    Else
        ss = sKey
    End If
    GetKey = ss
End Function

Private Function GetWb(ByVal sFull As String, bReadOnly As Boolean) As Workbook
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull, False, bReadOnly)
    End If
    
    Set GetWb = wb
End Function

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
    ClearArray arr
    GetArrayFromRange = arr
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

Private Sub DicAdd(dic As Object, arr As Variant)
    DicAddRecu dic, LBound(arr), arr
End Sub
Private Sub DicAddRecu(dic As Object, level As Long, arr As Variant)
    If Not dic.Exists(arr(level)) Then
        Set dic.Item(arr(level)) = CreateObject("Scripting.Dictionary")
    End If
    If level < UBound(arr) Then
        Dim bic As Object
        Set bic = dic.Item(arr(level))
        DicAddRecu bic, level + 1, arr
        
        Set dic.Item(arr(level)) = bic
    End If
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Column < Columns("J:J").Column Then Exit Sub
    If Target.Row < 5 Then Exit Sub
    Application.StatusBar = False
    
    Dim x2 As Long
    Dim y2 As Long
    Dim sh2 As Worksheet
    Set sh2 = Worksheets("ЗП сотрудников")
    With sh2
        On Error Resume Next
        y2 = WorksheetFunction.Match(Cells(Target.Row, 2).Value, .Columns(2), 0)
        'x2 = WorksheetFunction.Match(Cells(1, Target.Column).MergeArea.Cells(1, 1).Value, .Rows(1), 0)
        On Error GoTo 0
        If y2 > 0 Then
            x2 = myMatch(Cells(1, Target.Column).MergeArea.Cells(1, 1).Value, .Rows(1))
            If x2 > 0 Then
                If Cells(2, Target.Column).Value <> .Cells(2, x2).Value Then
                    x2 = x2 + 1
                End If
                If Cells(2, Target.Column).Value = .Cells(2, x2).Value Then
                    .Cells(y2, x2).Value = Target.Value
                    Application.StatusBar = .Name & "!" & Cells(y2, x2).Address(0, 0, xlA1) & " = " & .Cells(y2, x2).Value
                End If
            End If
        End If
    End With
End Sub

Private Function myMatch(vVal As Variant, rr As Range) As Long
    Dim arr As Variant
    arr = rr.Value
    
    Dim xa As Long
    For xa = 1 To UBound(arr, 2)
        If Not IsError(arr(1, xa)) Then
            If vVal = arr(1, xa) Then
                myMatch = xa
                Exit Function
            End If
        End If
    Next
End Function

Sub myRefresh()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        RefreshSheet sh
    Next
End Sub

Private Sub RefreshSheet(sh)
    If sh.Range("B2") = 0 Then
        sh.Columns("F:P").EntireColumn.Hidden = True
            Else
                sh.Columns("F:P").EntireColumn.Hidden = False
    If sh.Range("B3") = 0 Then
        sh.Columns("G:P").EntireColumn.Hidden = True
            Else
                sh.Columns("G:P").EntireColumn.Hidden = False
            End If
        End If
End Sub

=ЕСЛИОШИБКА(ИНДЕКС($E$1:$E$14;100-НАИБОЛЬШИЙ((СМЕЩ($E$10:$E$14;0;ПОИСКПОЗ($E$17;$F$9:$L$9;0))=$E$16)*(100-СТРОКА($E$10:$E$14));СТРОКА(1:1)));"")

=ОКРУГЛ((((B13*ЕСЛИ(E10="";ИНДЕКС($E$1:E13;МАКС(($E$1:E13>0)*СТРОКА($E$1:E13)));E10))*0,01));2)

=ЕСЛИ(E2=0;F1;E2)

    Dim myPhrase As Variant, myCell As Range
    Workbooks(1).Activate
    myPhrase = Range("F4").Value 'Это дата в ячейке
    Workbooks(2).Activate
    Do
        Set myCell = Range("G2:G1200").Find(myPhrase)
        If Not myCell Is Nothing Then
            MsgBox myCell.Row 'выводит номер строки, если нашел
            Exit Do
        Else
            MsgBox "даты нет!"
            myPhrase = myPhrase + 1
            If myPhrase > DateSerial(2030, 1, 1) Then
                MsgBox "Устал.", vbCritical
                Exit Do
            End If
            'Нужно настроить цикл на поиск ближайшей большей даты myPhrase, чтобы возвращал на If
        End If
    Loop

Option Explicit

Sub SplitActiveWorkbook()
    CloseEmptyWb
    SplitWorkbook ActiveWorkbook
End Sub

Private Sub SplitWorkbook(wbFrom As Workbook)
    Dim divisions As Object
    Set divisions = GetDivisions(wbFrom, "Итого", 2)
    If divisions.Count = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Dim division As Variant
    For Each division In divisions
        Application.StatusBar = division
        ExtractOneDivision division, wbFrom
    Next
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation, "Разделить книгу"
End Sub

Private Sub ExtractOneDivision(ByVal division As String, wbFrom As Workbook)
    Dim wbTarg As Workbook
    Set wbTarg = Workbooks.Add(1)
    
    Dim sh As Worksheet
    For Each sh In wbFrom.Worksheets
        If sh.Visible = xlSheetVisible Then
            If WorksheetFunction.CountIfs(sh.UsedRange.Columns(1), division) > 0 Then
                ExtractOneDivisionFromSheet division, sh, wbTarg
            End If
        End If
    Next
    
    If wbTarg.Sheets.Count = 1 Then
        wbTarg.Close False
    Else
        Application.DisplayAlerts = False
        wbTarg.Sheets(1).Delete
        Application.DisplayAlerts = True
        
        SaveWorkbook wbTarg, division, wbFrom.Path & "\"
        wbTarg.Close False
    End If
End Sub

Private Sub SaveWorkbook(wb As Workbook, division As String, sPath As String)
    Dim sName As String
    sName = division
    ReplaceSymbols sName
    sName = sName & ".xlsx"
    
    Dim sFull As String
    sFull = sPath & sName
    
    On Error Resume Next
    Workbooks(sName).Close False
    Kill sFull
    On Error GoTo 0
    wb.SaveAs sName
    
End Sub

Private Sub ExtractOneDivisionFromSheet(division As String, shFrom As Worksheet, wbTarg As Workbook)
    shFrom.Copy After:=wbTarg.Sheets(wbTarg.Sheets.Count)
    
    Dim shTarg As Worksheet
    Set shTarg = wbTarg.Sheets(wbTarg.Sheets.Count)
    
    Dim rd As Range
    Set rd = shTarg.UsedRange.Columns(1)
    
    Dim yb As Long
    On Error Resume Next
    yb = WorksheetFunction.Match(division, rd, 0)
    On Error GoTo 0
    If yb = 0 Then Exit Sub
    
    Dim divIndentLevel As Long
    divIndentLevel = rd.Cells(yb, 1).IndentLevel
    
    Dim yf As Long
    For yf = yb + 1 To rd.Rows.Count
        If rd.Cells(yf, 1).IndentLevel <= divIndentLevel Then Exit For
    Next
    yf = yf - 1
    
    If yf < rd.Rows.Count Then
        With shTarg
            .Range(rd.Cells(yf + 1), rd.Cells(rd.Rows.Count, 1)).EntireRow.Delete
        End With
    End If
    
    Dim yy As Long
    For yy = yb - 1 To 1 Step -1
        If rd.Cells(yy, 1).IndentLevel >= divIndentLevel Then
            rd.Cells(yy).EntireRow.Delete
        End If
    Next
    
End Sub

Private Function GetDivisionIndentLevel(rd As Range, division As String) As Long
    Dim yy As Long
    On Error Resume Next
    yy = WorksheetFunction.Match(division, rd, 0)
    On Error GoTo 0
    If yy > 0 Then
        GetDivisionIndentLevel = rd.Cells(yy, 1).IndentLevel
    End If
End Function

Private Function GetDivisions(wb As Workbook, sheetName As String, needIndentLevel As Long) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim sh As Worksheet
    On Error Resume Next
    Set sh = wb.Sheets(sheetName)
    On Error GoTo 0
    If Not sh Is Nothing Then
        Dim cl As Range
        For Each cl In sh.UsedRange.Columns(1).Cells
            If cl.IndentLevel = needIndentLevel Then
                dic(cl.Value) = 0
            End If
        Next
    End If
    
    Set GetDivisions = dic
End Function

Private Sub ReplaceSymbols(ss As String)
    Dim vv As Variant
    For Each vv In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]") '[] недопустимые только в имени листа
        ss = Replace(ss, vv, " ")
    Next
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 Sub Worksheet_Change(ByVal Target As Range)