=ЕСЛИОШИБКА(НАИБОЛЬШИЙ(ЕСЛИ(Лист1!$A$1:$D$34=N$18;Лист1!$A$2:$D$35);СТРОКА(N1));"")

Set Wb = Workbooks("BASA.xls")
with Wb.Sheets("SheetName")
    Temp = .Cells(.Rows.Count, 1).End(xlUp).Row
end with

=ЕСЛИ(СЧЁТЕСЛИ(F1:F$1;МАКС(C:C));"";МАКС(Ч(F1)+1;ПРОСМОТР(СТРОКА(F1)-1;МУМНОЖ((СТРОКА(B$1:B$5)>=ТРАНСП(СТРОКА(B$1:B$5)))*ТРАНСП(ЕСЛИОШИБКА(C$1:C$5-B$1:B$5+1;));СТРОКА(B$1:B$5)^0);$B$2:$B$3)))

Sub DBF()
    Const sTempFileName = "123456.dbf"
    Dim p$, f$, t$, c$, sFileName$, arr As Variant
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выбрать папку": .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            p = .SelectedItems(1) & "\"
        End If
    End With
    f = Dir(p & "*.dbf")
    t = "tmp.dbf"
    sFileName = p + f
    FileCopy sFileName, p + t
    c = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & p & ";Extended Properties=dBASE IV"
    With CreateObject("ADODB.Recordset")
        .Open "delete * from tmp", c
        Do While f <> ""
            If f <> t Then
                Name sFileName As p + sTempFileName
                .Open "insert into tmp select * from 123456", c
                Name p + sTempFileName As sFileName
             End If
            f = Dir$()
        Loop
        .Open "select * from tmp", c
        arr = .getrows
        .Close
        .Open "drop table tmp", c
    End With
End Sub

=G3-F3-ОТБР((G3-ОКРВНИЗ(F3-8;7)-8)/7)

dd()
    With ActiveSheet.UsedRange
        With Intersect(.SpecialCells(xlCellTypeConstants, 23).EntireRow, .Columns)
            .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C1"
        End With
        .Formula = .Value
        .Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .Cut [A1]
    End With
End Sub

Sub ss()

Sheets("Лист2").Select
lr = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Sheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr2
On Error Resume Next
V = Sheets("Лист2").Cells(i, 1).Value
m = Application.WorksheetFunction.VLookup(V, Sheets("Лист1").Range("A1:B" & lr2), 2, False)

If Not IsEmpty(m) Then Cells(i, 2).Value = Cells(i, 2).Value - m

Next i

End Sub

Sub ss()
    Dim i&, m As Variant
    With Sheets("Лист2")
        For Each v In .[A1].CurrentRegion.Columns(1).Value
            i = i + 1
            m = Application.VLookup(v, Sheets("Лист1").[A1].CurrentRegion, 2, False)
            With .Cells(i, 2)
            If Not IsEmpty(m) Then .Value = .Value - m
            End With
        Next
    End With
End Sub

Sub sdf()
    Dim Dic As Object
    Dim sh As Worksheet
    Dim r As Range, w As Range, c As Range
    Dim arr() As Variant, arr1 As Variant
    Dim i, j, k, l, m, n, o
    
    Set Dic = CreateObject("scripting.dictionary")
    For Each w In Sheets("Criteria").Cells.SpecialCells(xlCellTypeConstants, 1).Areas
        With w.Offset(-1, -1).Resize(1, 1)
            n = Abs(Mid(.Value, InStrRev(.Value, "(")))
        End With
        For Each c In w.Offset(, -1)
            Dic(n & "_" & c) = c.Offset(, 1)
        Next
    Next
    With Sheets("Result(было)")
        m = .UsedRange.Columns.Count
        n = .Columns(1).SpecialCells(xlCellTypeConstants, 23).Areas.Count
        Set r = .[A1].CurrentRegion
        ReDim arr(1 To n * m, 1 To 6)
        For i = 1 To n
            For j = 1 To m
                o = (i - 1) * m + j
                If Not IsEmpty(r(1, j)) Then
                    For k = 1 To 3
                       arr(o, k) = r(k, j)
                    Next
                    l = 0
                    For k = 4 To r.Rows.Count
                        l = l + Dic(arr(o, 2) & "_" & r(k, j))
                    Next
                    If l Then arr(o, 5) = l
                    s = ""
                    On Error Resume Next
                    With r.Columns(j)
                        arr1 = Intersect(.Offset(3), .Cells).SpecialCells(xlCellTypeConstants, 23)
                        If IsArray(arr1) Then
                            s = Join(Application.Transpose(arr1), "_")
                        ElseIf Not IsEmpty(arr1) Then
                            s = arr1
                        End If
                        Erase arr1
                    End With
                    arr(o, 6) = s
                End If
            Next
            Set r = r.End(xlDown).End(xlDown).CurrentRegion
            n = n + 1
        Next
    End With
    Application.ScreenUpdating = 0: Application.EnableEvents = 0
    With Sheets("+++++").UsedRange
        Intersect(.Offset(1), .Cells).Clear
        .Cells(4, 1).Resize(o, 6).Value = arr
    End With
    Application.ScreenUpdating = 1: Application.EnableEvents = 1
    Set Dic = Nothing
    Set r = Nothing
    Set w = Nothing
    Set c = Nothing
    Erase arr
End Sub

=СТРОКА()-СТРОКА([#Заголовки])