最新vba排序的10种方法(冒泡,选择等

2024年1月30日发(作者：)

/?page=1&id=3986&cid=44

VBA排序的10种方法（冒泡，选择等）

[日期：2011-08-07]

使用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 选择排序

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 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

4 快速排序

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

5 合并排序

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

6堆排序

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

7 组合排序

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

8 希尔排序

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

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