vba十大排序算法

Sub main() '归并排序
a = c_randomize_not_repeated.getRandDigit
sort a
Debug.Print 1
End Sub

Sub sort(a)
Dim aux()
ReDim aux(UBound(a))
doSort a, aux, 0, UBound(a)
End Sub

Sub doSort(a, aux, low, high)

If high <= low Then Exit Sub

Dim mid As Long

' 如果是奇数个，左边多一个
mid = Int((high + low) / 2)

doSort a, aux, low, mid

doSort a, aux, mid + 1, high

merge a, aux, low, mid, high

End Sub

Sub merge(a, aux, low, mid, high)
Dim i As Long

Dim j As Long

' 作为辅助数组的最低索引，开始
i = low

' 作为辅助防护组的最高索引，末尾
j = high

' 把i-mid,升序放入aux

Dim k As Long

For k = low To mid
aux(k) = a(k)
Next

' 把mid+1 到high ，降序放入aux
For k = mid + 1 To high
aux(k) = a(high - k + mid + 1)
Next

For k = low To high
If aux(i) < aux(j) Then
a(k) = aux(i)
i = i + 1
Else
a(k) = aux(j)
j = j - 1
End If
Next
End Sub

Function less(a, i, j) As Boolean
less = a(i) < a(j)
End Function

Sub exch(a, i, j)
Dim temp

temp = a(i)

a(i) = a(j)

a(j) = temp
End Sub
————————————————

 

Sub main()
'arr = Array(2, 3, 90, 22, 8, 98)
arr = c_randomize_not_repeated.getRandDigit
Call RadixSort(arr)
End Sub
Public Sub RadixSort(lngArray) '基数排序

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(lngSrc, lngDest, iLBound, iUBound, iDivisor)
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

'冒泡排序 1
Sub main()
arr = Array(2, 3, 90, 22, 8, 98)
Call BubbleSort(arr)
End Sub
'Public Sub BubbleSort(ByRef lngArray() As Long)
Public Sub BubbleSort(lngArray)
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排序的选择排序法 2

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

'快速排序法 3
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排序之插入排序法 4
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


' 堆排序法 5

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

'组合排序法 6

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

'基数排序法 8

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排序法 9

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