10种常用排序算法实现

在使用VBA进行写程序时，经常会做排序，下面将会给出一些常用的排序算法的实现，方便大家写程序参考，若代码中出现了错误，欢迎高手指正。

主要算法有：

1、（冒泡排序）Bubble sort
2、（选择排序）Selection sort
3、（插入排序）Insertion sort
4、（快速排序）Quick sort
5、（合并排序）Merge sort
6、（堆排序）Heap sort
7、（组合排序）Comb Sort
8、（希尔排序）Shell Sort
9、（基数排序）Radix Sort
10、Shaker Sort

第一种 （冒泡排序）Bubble sort
Public Sub BubbleSort(ByRef lngArray() As Long)
    Dim iOuter As Long
    Dim iInner As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Long

    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)

    '冒泡排序
    For iOuter = iLBound To iUBound - 1
        For iInner = iLBound To iUBound - iOuter - 1

            '比较相邻项
            If lngArray(iInner) > lngArray(iInner + 1) Then
                '交换值
                iTemp = lngArray(iInner)
                lngArray(iInner) = lngArray(iInner + 1)
                lngArray(iInner + 1) = iTemp
            End If

        Next iInner
    Next iOuter
End Sub

2、（选择排序）Selection sort
Public Sub SelectionSort(ByRef lngArray() As Long)
    Dim iOuter As Long
    Dim iInner As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Long
    Dim iMax As Long

    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)

    '选择排序
    For iOuter = iUBound To iLBound + 1 Step -1

        iMax = 0

        '得到最大值得索引
        For iInner = iLBound To iOuter
            If lngArray(iInner) > lngArray(iMax) Then iMax = iInner
        Next iInner

        '值交换
        iTemp = lngArray(iMax)
        lngArray(iMax) = lngArray(iOuter)
        lngArray(iOuter) = iTemp

    Next iOuter
End Sub

第三种 （插入排序）Insertion sort
Public Sub InsertionSort(ByRef lngArray() As Long)
    Dim iOuter As Long
    Dim iInner As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Long
   
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
   
    For iOuter = iLBound + 1 To iUBound
       
        '取得插入值
        iTemp = lngArray(iOuter)
       
        '移动已经排序的值
        For iInner = iOuter - 1 To iLBound Step -1
            If lngArray(iInner) <= iTemp Then Exit For
            lngArray(iInner + 1) = lngArray(iInner)
        Next iInner
       
        '插入值
        lngArray(iInner + 1) = iTemp
    Next iOuter
End Sub

第四种 （快速排序）Quick sort
Public Sub QuickSort(ByRef lngArray() As Long)
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Long
    Dim iOuter As Long
    Dim iMax As Long
   
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
   
    '若只有一个值，不排序
    If (iUBound - iLBound) Then
        For iOuter = iLBound To iUBound
            If lngArray(iOuter) > lngArray(iMax) Then iMax = iOuter
        Next iOuter
       
        iTemp = lngArray(iMax)
        lngArray(iMax) = lngArray(iUBound)
        lngArray(iUBound) = iTemp
   
        '开始快速排序
        InnerQuickSort lngArray, iLBound, iUBound
    End If
End Sub

Private Sub InnerQuickSort(ByRef lngArray() As Long, ByVal iLeftEnd As Long, ByVal iRightEnd As Long)
    Dim iLeftCur As Long
    Dim iRightCur As Long
    Dim iPivot As Long
    Dim iTemp As Long
   
    If iLeftEnd >= iRightEnd Then Exit Sub
   
    iLeftCur = iLeftEnd
    iRightCur = iRightEnd + 1
    iPivot = lngArray(iLeftEnd)
   
    Do
        Do
            iLeftCur = iLeftCur + 1
        Loop While lngArray(iLeftCur) < iPivot
       
        Do
            iRightCur = iRightCur - 1
        Loop While lngArray(iRightCur) > iPivot
       
        If iLeftCur >= iRightCur Then Exit Do
       
        '交换值
        iTemp = lngArray(iLeftCur)
        lngArray(iLeftCur) = lngArray(iRightCur)
        lngArray(iRightCur) = iTemp
    Loop
   
    '递归快速排序
    lngArray(iLeftEnd) = lngArray(iRightCur)
    lngArray(iRightCur) = iPivot
   
    InnerQuickSort lngArray, iLeftEnd, iRightCur - 1
    InnerQuickSort lngArray, iRightCur + 1, iRightEnd
End Sub

第五种 （合并排序）Merge sort
Public Sub MergeSort(ByRef lngArray() As Long)
    Dim arrTemp() As Long
    Dim iSegSize As Long
    Dim iLBound As Long
    Dim iUBound As Long
   
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
       
    ReDim arrTemp(iLBound To iUBound)
   
    iSegSize = 1
    Do While iSegSize < iUBound - iLBound
       
        '合并A到B
        InnerMergePass lngArray, arrTemp, iLBound, iUBound, iSegSize
        iSegSize = iSegSize + iSegSize
       
        '合并B到A
        InnerMergePass arrTemp, lngArray, iLBound, iUBound, iSegSize
        iSegSize = iSegSize + iSegSize
       
    Loop
End Sub

Private Sub InnerMergePass(ByRef lngSrc() As Long, ByRef lngDest() As Long, ByVal iLBound As Long, iUBound As Long, ByVal iSegSize As Long)
    Dim iSegNext As Long
   
    iSegNext = iLBound
   
    Do While iSegNext <= iUBound - (2 * iSegSize)
        '合并
        InnerMerge lngSrc, lngDest, iSegNext, iSegNext + iSegSize - 1, iSegNext + iSegSize + iSegSize - 1
       
        iSegNext = iSegNext + iSegSize + iSegSize
    Loop
   
    If iSegNext + iSegSize <= iUBound Then
        InnerMerge lngSrc, lngDest, iSegNext, iSegNext + iSegSize - 1, iUBound
    Else
        For iSegNext = iSegNext To iUBound
            lngDest(iSegNext) = lngSrc(iSegNext)
        Next iSegNext
    End If

End Sub

Private Sub InnerMerge(ByRef lngSrc() As Long, ByRef lngDest() As Long, ByVal iStartFirst As Long, ByVal iEndFirst As Long, ByVal iEndSecond As Long)
    Dim iFirst As Long
    Dim iSecond As Long
    Dim iResult As Long
    Dim iOuter As Long
   
    iFirst = iStartFirst
    iSecond = iEndFirst + 1
    iResult = iStartFirst
   
    Do While (iFirst <= iEndFirst) And (iSecond <= iEndSecond)
   
        If lngSrc(iFirst) <= lngSrc(iSecond) Then
            lngDest(iResult) = lngSrc(iFirst)
            iFirst = iFirst + 1
        Else
            lngDest(iResult) = lngSrc(iSecond)
            iSecond = iSecond + 1
        End If
       
        iResult = iResult + 1
    Loop
   
    If iFirst > iEndFirst Then
        For iOuter = iSecond To iEndSecond
            lngDest(iResult) = lngSrc(iOuter)
            iResult = iResult + 1
        Next iOuter
    Else
        For iOuter = iFirst To iEndFirst
            lngDest(iResult) = lngSrc(iOuter)
            iResult = iResult + 1
        Next iOuter
    End If
End Sub

第六种 （堆排序）Heap sort
Public Sub HeapSort(ByRef lngArray() As Long)
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iArrSize As Long
    Dim iRoot As Long
    Dim iChild As Long
    Dim iElement As Long
    Dim iCurrent As Long
    Dim arrOut() As Long
   
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
    iArrSize = iUBound - iLBound
   
    ReDim arrOut(iLBound To iUBound)
   
    'Initialise the heap
    'Move up the heap from the bottom
    For iRoot = iArrSize \ 2 To 0 Step -1
   
        iElement = lngArray(iRoot + iLBound)
        iChild = iRoot + iRoot
       
        'Move down the heap from the current position
        Do While iChild < iArrSize
           
            If iChild < iArrSize Then
                If lngArray(iChild + iLBound) < lngArray(iChild + iLBound + 1) Then
                    'Always want largest child
                    iChild = iChild + 1
                End If
            End If
           
            'Found a slot, stop looking
            If iElement >= lngArray(iChild + iLBound) Then Exit Do
           
            lngArray((iChild \ 2) + iLBound) = lngArray(iChild + iLBound)
            iChild = iChild + iChild
        Loop
       
        'Move the node
        lngArray((iChild \ 2) + iLBound) = iElement
    Next iRoot
   
    'Read of values one by one (store in array starting at the end)
    For iRoot = iUBound To iLBound Step -1
   
        'Read the value
        arrOut(iRoot) = lngArray(iLBound)
        'Get the last element
        iElement = lngArray(iArrSize + iLBound)
       
        iArrSize = iArrSize - 1
        iCurrent = 0
        iChild = 1
       
        'Find a place for the last element to go
        Do While iChild <= iArrSize
           
            If iChild < iArrSize Then
                If lngArray(iChild + iLBound) < lngArray(iChild + iLBound + 1) Then
                    'Always want the larger child
                    iChild = iChild + 1
                End If
            End If
           
            'Found a position
            If iElement >= lngArray(iChild + iLBound) Then Exit Do
           
            lngArray(iCurrent + iLBound) = lngArray(iChild + iLBound)
            iCurrent = iChild
            iChild = iChild + iChild
           
        Loop
       
        'Move the node
        lngArray(iCurrent + iLBound) = iElement
    Next iRoot
   
    'Copy from temp array to real array
    For iRoot = iLBound To iUBound
        lngArray(iRoot) = arrOut(iRoot)
    Next iRoot
End Sub

第七种 （组合排序）Comb Sort
Public Sub CombSort(ByRef lngArray() As Long)
    Dim iSpacing As Long
    Dim iOuter As Long
    Dim iInner As Long
    Dim iTemp As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iArrSize As Long
    Dim iFinished As Long
   
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
   
    'Initialise comb width
    iSpacing = iUBound - iLBound
   
    Do
        If iSpacing > 1 Then
            iSpacing = Int(iSpacing / 1.3)
           
            If iSpacing = 0 Then
                iSpacing = 1  'Dont go lower than 1
            ElseIf iSpacing > 8 And iSpacing < 11 Then
                iSpacing = 11 'This is a special number, goes faster than 9 and 10
            End If
        End If
       
        'Always go down to 1 before attempting to exit
        If iSpacing = 1 Then iFinished = 1
       
        'Combing pass
        For iOuter = iLBound To iUBound - iSpacing
            iInner = iOuter + iSpacing
           
            If lngArray(iOuter) > lngArray(iInner) Then
                'Swap
                iTemp = lngArray(iOuter)
                lngArray(iOuter) = lngArray(iInner)
                lngArray(iInner) = iTemp
               
                'Not finished
                iFinished = 0
            End If
        Next iOuter
       
    Loop Until iFinished
End Sub

第八种 （希尔排序）Shell Sort
Public Sub ShellSort(ByRef lngArray() As Long)
Dim iSpacing As Long
Dim iOuter As Long
Dim iInner As Long
Dim iTemp As Long
Dim iLBound As Long
Dim iUBound As Long
Dim iArrSize As Long

iLBound = LBound(lngArray)
iUBound = UBound(lngArray)

'Calculate initial sort spacing
iArrSize = (iUBound - iLBound) + 1
iSpacing = 1

If iArrSize > 13 Then
Do While iSpacing < iArrSize
iSpacing = (3 * iSpacing) + 1
Loop

iSpacing = iSpacing \ 9
End If

'Start sorting
Do While iSpacing

For iOuter = iLBound + iSpacing To iUBound

'Get the value to be inserted
iTemp = lngArray(iOuter)

'Move along the already sorted values shifting along
For iInner = iOuter - iSpacing To iLBound Step -iSpacing
'No more shifting needed, we found the right spot!
If lngArray(iInner) <= iTemp Then Exit For

lngArray(iInner + iSpacing) = lngArray(iInner)
Next iInner

'Insert value in the slot
lngArray(iInner + iSpacing) = iTemp
Next iOuter

'Reduce the sort spacing
iSpacing = iSpacing \ 3
Loop

End Sub

第九种 （基数排序）Radix Sort
Public Sub RadixSort(ByRef lngArray() As Long)
    Dim arrTemp() As Long
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iMax As Long
    Dim iSorts As Long
    Dim iLoop As Long

    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
   
    'Create swap array
    ReDim arrTemp(iLBound To iUBound)

    iMax = &H80000000
    'Find largest
    For iLoop = iLBound To iUBound
        If lngArray(iLoop) > iMax Then iMax = lngArray(iLoop)
    Next iLoop
   
    'Calculate how many sorts are needed
    Do While iMax
        iSorts = iSorts + 1
        iMax = iMax \ 256
    Loop
   
    iMax = 1
   
    'Do the sorts
    For iLoop = 1 To iSorts
       
        If iLoop And 1 Then
            'Odd sort -> src to dest
            InnerRadixSort lngArray, arrTemp, iLBound, iUBound, iMax
        Else
            'Even sort -> dest to src
            InnerRadixSort arrTemp, lngArray, iLBound, iUBound, iMax
        End If
       
        'Next sort factor
        iMax = iMax * 256
    Next iLoop
   
    'If odd number of sorts we need to swap the arrays
    If (iSorts And 1) Then
        For iLoop = iLBound To iUBound
            lngArray(iLoop) = arrTemp(iLoop)
        Next iLoop
    End If
End Sub

Private Sub InnerRadixSort(ByRef lngSrc() As Long, ByRef lngDest() As Long, ByVal iLBound As Long, ByVal iUBound As Long, ByVal iDivisor As Long)
    Dim arrCounts(255) As Long
    Dim arrOffsets(255) As Long
    Dim iBucket As Long
    Dim iLoop As Long
   
    'Count the items for each bucket
    For iLoop = iLBound To iUBound
        iBucket = (lngSrc(iLoop) \ iDivisor) And 255
        arrCounts(iBucket) = arrCounts(iBucket) + 1
    Next iLoop
   
    'Generate offsets
    For iLoop = 1 To 255
        arrOffsets(iLoop) = arrOffsets(iLoop - 1) + arrCounts(iLoop - 1) + iLBound
    Next iLoop
       
    'Fill the buckets
    For iLoop = iLBound To iUBound
        iBucket = (lngSrc(iLoop) \ iDivisor) And 255
        lngDest(arrOffsets(iBucket)) = lngSrc(iLoop)
        arrOffsets(iBucket) = arrOffsets(iBucket) + 1
    Next iLoop
End Sub

第十种 Shaker Sort
Public Sub ShakerSort(ByRef lngArray() As Long)
Dim iLower As Long
Dim iUpper As Long
Dim iInner As Long
Dim iLBound As Long
Dim iUBound As Long
Dim iTemp As Long
Dim iMax As Long
Dim iMin As Long

iLBound = LBound(lngArray)
iUBound = UBound(lngArray)

iLower = iLBound - 1
iUpper = iUBound + 1

Do While iLower < iUpper

iLower = iLower + 1
iUpper = iUpper - 1

iMax = iLower
iMin = iLower

'Find the largest and smallest values in the subarray
For iInner = iLower To iUpper
If lngArray(iInner) > lngArray(iMax) Then
iMax = iInner
ElseIf lngArray(iInner) < lngArray(iMin) Then
iMin = iInner
End If
Next iInner

'Swap the largest with last slot of the subarray
iTemp = lngArray(iMax)
lngArray(iMax) = lngArray(iUpper)
lngArray(iUpper) = iTemp

'Swap the smallest with the first slot of the subarray
iTemp = lngArray(iMin)
lngArray(iMin) = lngArray(iLower)
lngArray(iLower) = iTemp

Loop
End Sub