Fatal编程技术网
  • vba/
  • Vba 是否有不调用自身/不使用递归的快速排序例程

Vba 是否有不调用自身/不使用递归的快速排序例程

vba excel

Vba 是否有不调用自身/不使用递归的快速排序例程,vba,excel,vb.net-2010,Vba,Excel,Vb.net 2010,众所周知的快速排序例程在最后使用两个递归调用。但是，在Excel VBA中对大型未排序数组（>40万个元素）使用快速排序例程可能会由于许多递归调用而导致内存堆栈溢出 Public Sub dQsort(List() As Double, ByVal min As Long, ByVal max As Long) Dim med_value As Double Dim hi As Long Dim lo As Long Dim i As Long ' If

众所周知的快速排序例程在最后使用两个递归调用。但是，在Excel VBA中对大型未排序数组（>40万个元素）使用快速排序例程可能会由于许多递归调用而导致内存堆栈溢出

Public Sub dQsort(List() As Double, ByVal min As Long, ByVal max As Long)
    Dim med_value As Double
    Dim hi As Long
    Dim lo As Long
    Dim i As Long

    ' If min >= max, the list contains 0 or 1 items so it is sorted.
    If min >= max Then GoTo ErrorExit
    ' Pick the dividing value.
    i = (max + min + 1) / 2
    med_value = List(i)
    ' Swap it to the front.
    List(i) = List(min)
    lo = min
    hi = max

    Do
        ' Look down from hi for a value < med_value.
        Do While List(hi) >= med_value
            hi = hi - 1
            If hi <= lo Then Exit Do
        Loop
        If hi <= lo Then
            List(lo) = med_value
            Exit Do
        End If
        ' Swap the lo and hi values.
        List(lo) = List(hi)
        ' Look up from lo for a value >= med_value.
        lo = lo + 1
        Do While List(lo) < med_value
            lo = lo + 1
            If lo >= hi Then Exit Do
        Loop
        If lo >= hi Then
            lo = hi
            List(hi) = med_value
            Exit Do
        End If
        ' Swap the lo and hi values.
        List(hi) = List(lo)
    Loop

    ' Sort the two sublists.
    dQsort List(), min, lo - 1  ' Recursive call which I would like to avoid
    dQsort List(), lo + 1, max  ' Recursive call which I would like to avoid

End Sub

Public Sub-dQsort（List（）为Double，ByVal-min为Long，ByVal-max为Long）
Dim med_值为双精度
你好，再见
昏昏欲睡
我想我会坚持多久
'如果最小值>=最大值，则列表包含0或1项，因此对其进行排序。
如果最小值>=最大值，则转到错误退出
'选择分割值。
i=（最大+最小+1）/2
中值=列表（i）
“换到前面去。
列表（i）=列表（最小值）
lo=最小值
hi=最大值
做
'从hi向下查看值<中间值。
Do While List（hi）>=中间值
hi=hi-1
如果hi=hi，则退出Do
环
如果lo>=hi，则
低=高
列表（hi）=中间值
退出Do
如果结束
'交换lo和hi值。
列表（hi）=列表（lo）
环
'对两个子列表进行排序。
dQsort List（），min，lo-1'递归调用，我希望避免这种调用
dQsort List（），lo+1，max'递归调用，我希望避免这种调用
端接头
我的问题是：谁知道一个经过修改的快速排序例程，与传统的快速排序例程相比，它只会在额外的时间内带来很小的损失（由于上面提到的内存堆栈溢出，对于相对较小的未排序数组，您只能在“旧”和“新”例程之间进行比较）

“可能已经有你答案的问题”的答案不是我问题的答案

这里有一个简单的双打排序：

Public Sub aSort(ByRef InOut)

    Dim i As Long, J As Long, Low As Long
    Dim Hi As Long, Temp As Variant

    Low = LBound(InOut)
    Hi = UBound(InOut)

    J = (Hi - Low + 1) \ 2
    Do While J > 0
        For i = Low To Hi - J
          If InOut(i) > InOut(i + J) Then
            Temp = InOut(i)
            InOut(i) = InOut(i + J)
            InOut(i + J) = Temp
          End If
        Next i
        For i = Hi - J To Low Step -1
          If InOut(i) > InOut(i + J) Then
            Temp = InOut(i)
            InOut(i) = InOut(i + J)
            InOut(i + J) = Temp
          End If
        Next i
        J = J \ 2
    Loop
End Sub

Sub MAIN()
    Dim ary(1 To 3) As Double, msg As String
    Dim i As Long

    ary(1) = 0.4
    ary(2) = 0.1
    ary(3) = 0.5

    Call aSort(ary)

    msg = ""
    For i = 1 To 3
         msg = msg & ary(i) & vbCrLf
    Next i

    MsgBox msg
End Sub
我不知道它是否足够快

提到的合并排序与传统的快速排序具有相同的缺点：它还使用递归调用（请参阅下面的Excel VBA代码，改编自命名的Wiki页面）。TopDownMergeSort仅对n-1数组值进行排序。因此，您需要在排序数组中插入第n个值（当然是在正确的位置）

子测试\u方法\u合并排序（）
'带双精度的数组adData，从索引=1开始
调用TopDownMergeSort（adData）
调用InsertintoSorterDarray（adData，adData（UBound（adData）），1，False）
端接头
“//数组A[]具有要排序的项；数组B[]是一个工作数组。
子TopDownMergeSort（ByRef A（）作为双精度）
Dim B（）为双精度
长
我想我会坚持多久
“//将数组A[]复制到B[]
n=UBound（A）
雷迪姆B（n）
对于i=1到n
B（i）=A（i）
接下来我
“//将数据从B[]排序到A[]
TopDownSplitMerge B，1，n，A
端接头
'使用数组B[]作为源对给定的数组A[]运行进行排序。
“伊贝金是包容性的；iEnd是独占的（集合中没有[iEnd]）。
Sub-TopDownSplitMerge（ByRef B（）为双精度，ByVal iBegin为长精度，ByVal iEnd为长精度，ByRef A（）为双精度）
朦胧如长
双色调暗dTmp
如果（iEnd-iBegin）<2，则退出Sub'//如果运行大小==1
“//将长度超过1项的跑步分成两半
IMIDLE=（iEnd+iBegin）/2'//IMIDLE=中点
“//将两个运行从数组A[]递归排序到B[]
TopDownSplitMerge A、iBegin、Imidle、B'//对左侧运行进行排序
TopDownSplitMerge A、IMIDLE、iEnd、B'//对正确的运行进行排序
“//将数组B[]中的结果运行合并到[]
TopDownMerge B、iBegin、Imidle、iEnd、A
端接头
“//左半源代码是[iBegin:iMiddle-1]。
“//右半源代码是[IMIDLE:iEnd-1]。
'//结果是B[iBegin:iEnd-1]。
Sub-TopDownMerge（ByRef A（）为双精度，ByVal iBegin为长精度，ByVal Imidle为长精度，ByVal iEnd为长精度，ByRef B（）为双精度）
我想我会坚持多久
Dim j尽可能长
暗k一样长
i=iBegin
j=imidle
“//当左行或右行中有元素时。。。
对于k=iBegin到iEnd-1
“//如果左运行标头存在且为=iEnd）或（A（i）=max，则列表包含0或1项，因此对其进行排序。
如果最小值>=最大值，则转到出口点
调用初始化（l_列表，最小值，最大值）
开始：
如果abTopDownReady（l_列表，1）和abTopDownReady（l_列表，2），则
abTopDownReady（alParentIndex（l_列表）、aiTopDownIndex（l_列表））=True
l_列表=l_列表-1
如果l_列表>=0，则
开始
其他的
'就绪/列表已排序
转到出口点
如果结束
如果结束
最小值=最小值（l_列表）
最大值=alMax（l_列表）
' -----------------------------------
“快速排序的传统部分
'选择分割值。
i=（最大+最小+1）/2
中值=列表（i）
“换到前面去。
列表（i）=列表（最小值）
lo=最小值
hi=最大值
做
'从hi向下查看值<中间值。
Do While List（hi）>=中间值
hi=hi-1
如果hi=hi，则退出Do
环
如果lo>=hi，则
低=高
列表（hi）=中间值
退出Do
如果结束
'交换lo和hi值。
列表（hi）=列表（lo）
环
“快速排序传统部分的结束
' -----------------------------------------
如果最大值大于（lo+1），则
'作为新子列表的顶部部分
l_列表=l_列表+1
Init_newpublist l_List，l_List-1，1，lo+1，Max
如果（lo-1）>最小值，则
“作为新的子列表的向下部分
l_列表=l_列表+1
Init_newpublist l_List，l_List-2，2，Min，lo-1
其他的
'下部件（=2）已排序/准备就绪
abTopDownReady（l_列表-1,2）=真
如果结束
ElseIf（lo-1）>最小值
'顶部已排序/准备就绪。。。
abTopDownReady（l_列表，1）=真
“…下面的部分是一个新的子列表。
l_列表=l_列表+1
Init_newpublist l_List，l_List-1，2，Min，lo-1
其他的
'顶部（=1）和底部（=2）都已排序/准备就绪。。。
abTopDownReady（l_列表，1）=真
abTopDownRead

Sub Test_Method_MergeSort()

    'Array adData with Doubles, starting from index = 1
    Call TopDownMergeSort(adData)
    Call InsertIntoSortedArray(adData, adData(UBound(adData)), 1, False)

End Sub

'// Array A[] has the items to sort; array B[] is a work array.
Sub TopDownMergeSort(ByRef A() As Double)
    Dim B() As Double
    Dim n As Long
    Dim i As Long

    '// duplicate array A[] into B[]
    n = UBound(A)
    ReDim B(n)

    For i = 1 To n
        B(i) = A(i)
    Next i

    '// sort data from B[] into A[]
    TopDownSplitMerge B, 1, n, A

End Sub

'Sort the given run of array A[] using array B[] as a source.
'iBegin is inclusive; iEnd is exclusive (A[iEnd] is not in the set).

Sub TopDownSplitMerge(ByRef B() As Double, ByVal iBegin As Long, ByVal iEnd As Long, ByRef A() As Double)
    Dim iMiddle As Long
    Dim dTmp As Double

    If (iEnd - iBegin) < 2 Then Exit Sub '  // if run size == 1

    '// split the run longer than 1 item into halves
    iMiddle = (iEnd + iBegin) / 2   '// iMiddle = mid point

    '// recursively sort both runs from array A[] into B[]
    TopDownSplitMerge A, iBegin, iMiddle, B   '// sort the left run
    TopDownSplitMerge A, iMiddle, iEnd, B    '// sort the right run

    '// merge the resulting runs from array B[] into A[]
    TopDownMerge B, iBegin, iMiddle, iEnd, A

End Sub

'// Left source half is A[ iBegin:iMiddle-1].
'// Right source half is A[iMiddle:iEnd-1].
'// Result is B[ iBegin:iEnd-1].
Sub TopDownMerge(ByRef A() As Double, ByVal iBegin As Long, ByVal iMiddle As Long, ByVal iEnd As Long, ByRef B() As Double)
    Dim i As Long
    Dim j As Long
    Dim k As Long

    i = iBegin
    j = iMiddle

    '// While there are elements in the left or right runs...
    For k = iBegin To iEnd - 1

        '// If left run head exists and is <= existing right run head.
        If ((i < iMiddle) And ((j >= iEnd) Or (A(i) <= A(j)))) Then
            B(k) = A(i)
            i = i + 1

        Else
            B(k) = A(j)
            j = j + 1

        End If

    Next k
End Sub

Sub InsertIntoSortedArray(ByRef dSortedArray() As Double, ByVal dNewValue As Double, ByVal LowerBound As Long, Optional ByVal RedimNeeded As Boolean = False)    ', xi As Long) As Long
    Dim n As Long, ii As Long

    n = UBound(dSortedArray)
    If RedimNeeded Then
        ReDim Preserve dSortedArray(n + 1)

    Else
        n = n - 1

    End If 

    ii = n + 1
    Do Until dSortedArray(ii - 1) <= dNewValue Or ii < (LowerBound + 1)
        dSortedArray(ii) = dSortedArray(ii - 1)
        ii = ii - 1
    Loop
    dSortedArray(ii) = dNewValue

End Sub



' This code belongs to one and the same Excel’s  code module 
Private Const msMODULE As String = "M_QSort"

Private alMin() As Long
Private alMax() As Long
Private abTopDownReady() As Boolean
Private aiTopDownIndex() As Integer  ' 1 (= TopList) or 2 ( = DownList)
Private alParentIndex() As Long

Sub IAMWW_Qsort(ByRef List() As Double, ByVal Min As Long, ByVal Max As Long)
    Dim med_value As Double
    Dim hi As Long
    Dim lo As Long
    Dim i As Long

    Dim l_List As Long

    ' If min >= max, the list contains 0 or 1 items so it is sorted.
    If Min >= Max Then GoTo ExitPoint

    Call Init(l_List, Min, Max)

Start:

    If abTopDownReady(l_List, 1) And abTopDownReady(l_List, 2) Then
        abTopDownReady(alParentIndex(l_List), aiTopDownIndex(l_List)) = True

        l_List = l_List - 1
        If l_List >= 0 Then
            GoTo Start

        Else
            ' Ready/list is sorted
            GoTo ExitPoint

        End If

    End If

    Min = alMin(l_List)
    Max = alMax(l_List)

    ' -----------------------------------
    ' The traditional part of QuickSort

    ' Pick the dividing value.
    i = (Max + Min + 1) / 2
    med_value = List(i)
    ' Swap it to the front.
    List(i) = List(Min)
    lo = Min
    hi = Max

    Do
        ' Look down from hi for a value < med_value.
        Do While List(hi) >= med_value
           hi = hi - 1
           If hi <= lo Then Exit Do
        Loop
        If hi <= lo Then
            List(lo) = med_value
            Exit Do
        End If
        ' Swap the lo and hi values.
        List(lo) = List(hi)
        ' Look up from lo for a value >= med_value.
        lo = lo + 1
        Do While List(lo) < med_value
            lo = lo + 1
            If lo >= hi Then Exit Do
        Loop
        If lo >= hi Then
           lo = hi
            List(hi) = med_value
            Exit Do
        End If
        ' Swap the lo and hi values.
        List(hi) = List(lo)
    Loop

    ' End of the traditional part of QuickSort
    ' -----------------------------------------

    If Max > (lo + 1) Then
        ' top part as a new sublist
        l_List = l_List + 1
        Init_NewSubList l_List, l_List - 1, 1, lo + 1, Max

        If (lo - 1) > Min Then
            ' down part as a new sublist
            l_List = l_List + 1
            Init_NewSubList l_List, l_List - 2, 2, Min, lo - 1

        Else
            ' down part (=2) is sorted/ready
        abTopDownReady(l_List - 1, 2) = True

        End If


    ElseIf (lo - 1) > Min Then
        ' Top part is sorted/ready...
        abTopDownReady(l_List, 1) = True

        ' ... and down part is a new sublist.
        l_List = l_List + 1
        Init_NewSubList l_List, l_List - 1, 2, Min, lo - 1

    Else
        ' Both the top (=1) and down part (=2) are sorted/ready ...
        abTopDownReady(l_List, 1) = True
        abTopDownReady(l_List, 2) = True

        ' ... and therefore, the parent (sub)list is also sorted/ready ...
        abTopDownReady(alParentIndex(l_List), aiTopDownIndex(l_List)) = True

        ' ... and continue with the before last created new sublist.
        l_List = l_List - 1

    End If

    If l_List >= 0 Then GoTo Start    

ExitPoint:

End Sub

Private Sub Init_NewSubList(ByVal Nr As Long, ByVal Nr_Parent As Long, ByVal iTopDownIndex As Integer, ByVal Min As Long, ByVal Max As Long)

    ' Nr = number of new sublist
    ' Nr_Parent = the parent's list number of the new sublist
    ' iTopDownIndex = index for top (=1) or down part (=2) sublist


    aiTopDownIndex(Nr) = iTopDownIndex  '= 2 ' new sub list is a down part sublist
    alParentIndex(Nr) = Nr_Parent  'l_List - 2
    abTopDownReady(Nr, 1) = False 'The new sublist has a top part sublist, not ready yet
    abTopDownReady(Nr, 2) = False 'The new sublist has a down part sublist, not ready yet

    ' min and max values of the new sublist
    alMin(Nr) = Min
    alMax(Nr) = Max 'lo - 1

End Sub

Private Sub Init(ByRef Nr As Long, ByVal Min As Long, ByVal Max As Long)
    Dim lArraySize As Long

    lArraySize = Max - Min + 1

    ReDim alMin(lArraySize)
    ReDim alMax(lArraySize)
    ReDim abTopDownReady(lArraySize, 2)
    ReDim aiTopDownIndex(lArraySize)
    ReDim alParentIndex(lArraySize)

    Nr = 0
    alMin(Nr) = Min
    alMax(Nr) = Max

    aiTopDownIndex(0) = 2        ' Initial list is assumed to be a down part (= 2)

End Sub