在使用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

轉載于:https://www.cnblogs.com/top5/archive/2010/09/18/1830448.html

總結

以上是生活随笔為你收集整理的10种常用排序算法实现的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。