Option Explicit
Private Type QuickStack
    'тип для QuickSort
    Low As Long
    High As Long
End Type
'Private Type extrem
'    min As Long
'    max As Long
'End TypeSub sumel(rng As Range, zn As Double, Optional shrp As Double = 0.001)
Dim arr(), sm#(), i&, lim() As QuickStack, sm_r#(), d#, nur&, pur&, cl As New Collection
Dim d_min As Double, abs_d As Double
ReDim lim(15)
ReDim sm(15)
ReDim sm_r(15)
sm(0) = zn
arr = Application.Transpose(rng)
QuickSortNonRecursive___ arr
lim(0).High = UBound(arr)
lim(0).Low = LBound(arr)
sm(0) = sm(0)
nur = 0
pur = -1
d_min = arr(lim(0).Low)
Do
 sm_r(nur) = 0
   For i = lim(nur).High To lim(nur).Low Step -1
        d = sm(nur) - sm_r(nur) - arr(i)
        abs_d = Abs(d)
        If abs_d < d_min Then d_min = abs_d
        If abs_d < shrp Then
            cl.Add arr(i), CStr(i)
'            MsgBox "ok"
            Exit Do
        End If
        If d < 0 Then
            If sm_r(nur) = 0 Then
                lim(nur).High = i - 1
            Else
               Exit For
            End If
        Else
            sm_r(nur) = sm_r(nur) + arr(i)
            cl.Add arr(i), CStr(i)
        End If
    Next
    If i < lim(nur).Low Or pur > 0 Then
        If nur > 0 Then
            If pur = 0 Then
            Else
                lim(nur).High = lim(nur - 1).Low - 1
                If pur < 0 Then
                    pur = lim(nur - 1).High
                Else
                    If pur > lim(nur - 1).Low Then
                        pur = pur - 1
                    Else
                        pur = -1
                    End If
                End If
                If i < lim(nur).Low Then pur = -1
                If pur > 0 Then
                    sm(nur) = sm(nur - 1) - sm_r(nur - 1) + arr(pur)
                    cl.Remove CStr(pur)
                Else
                    On Error Resume Next
                    For i = lim(nur).Low To lim(nur).High
                        cl.Remove CStr(i)
                    Next
                    nur = nur - 1
                    For i = lim(nur).Low To lim(nur).High
                        cl.Remove CStr(i)
                    Next
                    On Error GoTo 0
                    lim(nur).High = lim(nur).High - 1
                    lim(nur).Low = 1
                End If
            End If
        Else
            Exit Do
        End If
    Else
        lim(nur + 1).Low = lim(nur).Low
        lim(nur).Low = i + 1
        sm(nur + 1) = sm(nur) - sm_r(nur)
        nur = nur + 1
        lim(nur).High = i
    End If
Loop
Range("c:c").ClearContents
If d_min > shrp Then
    MsgBox "точность не достигнута   -  " & Format(d_min, "#0.00#")
Else
    Dim y As Long
    Columns(2).ClearContents
    For i = 1 To cl.Count
        Cells(i, 3) = cl(i)
        y = WorksheetFunction.Match(cl(i), Columns(1), 0)
        Cells(y, 2).Value = 1
    Next
    MsgBox "OK"
End If
End Sub
Sub testsumel()    sumel Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)), [d2], [d3]
End SubPublic Sub QuickSortNonRecursive___(SortArray())
Dim i As Long, j As Long, lb As Long, ub As Long
Dim stack() As QuickStack, stackpos As Long, ppos As Long, pivot As Variant, swp, maxstack&
    On Error GoTo er
    ReDim stack(1 To 16)
    stackpos = 1    stack(1).Low = LBound(SortArray)
    stack(1).High = UBound(SortArray)
    Do
        'Взять границы lb и ub текущего массива из стека.
        lb = stack(stackpos).Low
        ub = stack(stackpos).High
        stackpos = stackpos - 1
        Do
            'Шаг 1. Разделение по элементу pivot
            ppos = (lb + ub) \ 2
            i = lb: j = ub: pivot = SortArray(ppos)
            Do
                While SortArray(i) < pivot: i = i + 1: Wend
                While pivot < SortArray(j): j = j - 1: Wend
                If i > j Then Exit Do
'                If i <> j Then
                 swp = SortArray(i): SortArray(i) = SortArray(j): SortArray(j) = swp
'                End If
                i = i + 1
                j = j - 1
'                End If
           Loop While i <= j            'Сейчас указатель i указывает на начало правого подмассива,
            'j - на конец левого lb ? j ? i ? ub.
            'Возможен случай, когда указатель i или j выходит за границу массива
            'Шаги 2, 3. Отправляем большую часть в стек  и двигаем lb,ub            If i < ppos Then   'правая часть больше
                If i < ub Then
                    stackpos = stackpos + 1
                    stack(stackpos).Low = i
                    stack(stackpos).High = ub
                End If
                ub = j        'следующая итерация разделения будет работать с левой частью
            Else
                If j > lb Then
                    stackpos = stackpos + 1
                    stack(stackpos).Low = lb
                    stack(stackpos).High = j
                End If
                lb = i
            End If
'            If maxstack < stackpos Then maxstack = stackpos
        Loop While lb < ub
    Loop While stackpos
    Exit Sub
er: ReDim Preserve stack(1 To UBound(stack) * 2)
    Resume
'    Debug.Print maxstack
End Sub