excel
vba数组排序的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
1、冒泡排序
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、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
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
4、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
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
7、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
8、组合排序法
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
9、基数排序法
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
10、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
加载中，请稍候......
加载中…
喜欢