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

/show.aspx?page=1&id=3986&cid=44VBA排序的10种方法（冒泡，选择等）日期：2011-08-07 使用VBA进行写程序时，经常会做排序，下面将会给出一些常用的排序算法的实现，方便大家写程序参考，若代码中出现了错误，欢迎高手指正。主要算法有：1、（冒泡排序）Bubble sort2、（选择排序）Selection sort3、（插入排序）Insertion sort4、（快速排序）Quick sort5、（合并排序）Merge sort6、（堆排序）Heap sort7、（组合排序）Comb Sort8、（希尔排序）Shell Sort9、（基数排序）Radix Sort10、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 iOuterEnd Sub2 选择排序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 iOuterEnd Sub3 插入排序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) lngArray(iMax) Then iMax = iOuter Next iOuter iTemp = lngArray(iMax) lngArray(iMax) = lngArray(iUBound) lngArray(iUBound) = iTemp 开始快速排序 InnerQuickSort lngArray, iLBound, iUBound End IfEnd 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 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, iRightEndEnd Sub5 合并排序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 LoopEnd SubPrivate 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 IfEnd SubPrivate 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) 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 IfEnd Sub6堆排序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) 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) 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 iRootEnd Sub7 组合排序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 lngArray(iInner) Then Swap iTemp = lngArray(iOuter) lngArray(iOuter) = lngArray(iInner) lngArray(iInner) = iTemp Not finished iFinished = 0 End If Next iOuter Loop Until iFinishedEnd Sub8 希尔排序Public Sub ShellSort(ByRef lngArray() As Long)Dim iSpacing As LongDim iOuter As LongDim iInner As LongDim iTemp As LongDim iLBound As LongDim iUBound As LongDim iArrSize As LongiLBound = LBound(lngArray)iUBound = UBound(lngArray)Calculate initial sort spacingiArrSize = (iUBound - iLBound) + 1iSpacing = 1If iArrSize 13 ThenDo While iSpacing iArrSizeiSpacing = (3 * iSpacing) + 1LoopiSpacing = iSpacing 9End IfStart sortingDo While iSpacingFor iOuter = iLBound + iSpacing To iUBoundGet the value to be insertediTemp = lngArray(iOuter)Move along the already sorted values shifting alongFor iInner = iOuter - iSpacing To iLBound Step -iSpacingNo more shifting needed, we found the right spot!If lngArray(iInner) 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 IfEnd SubPrivate 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 -