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

'冒泡排序

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

VBA排序的选择排序法

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

快速排序法
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

VBA排序之插入排序法
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

堆排序法

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

组合排序法

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

VBA排序之希尔排序法
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

基数排序法

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