1 Sub Main() 2 Application.ScreenUpdating = False 3 On Error GoTo Line 4 Dim Ar(), NO As Integer 5 Ar = Application.WorksheetFunction.Transpose((Range("a1").CurrentRegion.Value)) 6 NO = VBA.InputBox("输入算法方式: 1、BubbleSort,2、CountingSort,3、QuickSort，4、WorksheetSort", "方式选择", "1") ' 7 Dim T 8 T = Timer 9 Select Case NO 10 Case Is = 1 11 BubbleSort Ar 12 Case Is = 2 13 CountingSort Ar 14 Case Is = 3 15 QuickSort Ar, LBound(Ar), UBound(Ar) 16 Case Is = 4 17 WorkShtSort Ar 18 Case Else 19 MsgBox "错误输入", vbInformation + vbOKOnly 20 Exit Sub 21 End Select 22 23 Range("c1").Resize(UBound(Ar), 1) = Application.WorksheetFunction.Transpose(Ar) 24 Application.ScreenUpdating = True 25 MsgBox Format(Timer - T, "0.00Sec"), vbInformation + vbOKOnly 26 Exit Sub 27 Line: MsgBox Err.Description 28 End Sub 29 30 '====================================================冒泡排序=================================================== 31 Sub BubbleSort(ByRef list) 'ByRef 引用传递 32 Dim L As Long, H As Long '上下标 33 Dim i As Long, J As Long 34 Dim Temp '过渡 35 L = LBound(list): H = UBound(list) 36 For i = 1 To (H - 1) '有序区间极值 37 For J = (i + 1) To H '无序区间每个值 38 If list(i) > list(J) Then 39 Temp = list(i) ' 取出较大值指向H 即升序 40 list(i) = list(J) 41 list(J) = Temp 42 End If 43 Next J 44 Next i 45 End Sub 46 47 '==================================================计数排序===================================================== 48 Sub CountingSort(ByRef list) '只适合long类型的数组 49 Dim Lo As Long, Hi As Long, Count() '2个极值和Count存储数组 50 Dim L As Long, H As Long '上下标 51 Dim i As Long, J As Long 52 Lo = Application.WorksheetFunction.min(list) 53 Hi = Application.WorksheetFunction.max(list) 54 ReDim Count(Lo To Hi) 55 L = LBound(list): H = UBound(list) 56 '遍历list 填充Count数组 57 For i = L To H 58 Count(list(i)) = Count(list(i)) + 1 '索引++ 59 Next i 60 61 Dim K As Long '初始下标 62 K = L 63 '遍历Count数组 排序list 64 For i = Lo To Hi '升序 65 For J = 1 To Count(i) 66 list(K) = i 67 K = K + 1 68 Next J 69 Next i 70 End Sub 71 72 '==================================================快速排序===================================================== 73 Sub QuickSort(ByRef list, L, H) 'LH 左右指针，二分区间 74 If L >= H Then Exit Sub 75 Dim RValue As Long, Rd As Long 76 Randomize '初始化 77 Rd = Int((H - L + 1) * Rnd + L) 78 RValue = list(Rd) '基准值 79 list(Rd) = list(L) 80 81 Dim Lo As Long, Hi As Long '二分法上下限 82 Lo = L: Hi = H 83 Do '大循环'挖坑法 84 Do While list(Hi) >= RValue ' Hi>>>>Lo 85 Hi = Hi - 1 86 If Hi = Lo Then Exit Do '指针相遇即退出 87 Loop 88 If Hi = Lo Then 89 list(Lo) = RValue '不满足排序的递归前需要list元素还原 90 Exit Do '退出大循环 91 Else 92 list(Lo) = list(Hi) 93 End If 94 '----------------------------------------- 95 Do While list(Lo) < RValue 'Lo>>>>Hi 96 Lo = Lo + 1 97 If Hi = Lo Then Exit Do '指针相遇即退出 98 Loop 99 If Lo = Hi Then 100 list(Hi) = RValue '不满足排序的递归前需要list元素还原 101 Exit Do '退出大循环 102 Else 103 list(Hi) = list(Lo) 104 End If 105 Loop 106 '------递归------ 107 QuickSort list, L, Lo - 1 108 QuickSort list, Lo + 1, H 109 End Sub 110 111 '================================================工作表排序===================================================== 112 Sub WorkShtSort(ByRef list) 113 Application.DisplayAlerts = False 114 Dim Sht As Worksheet 115 Set Sht = Worksheets.Add(after:=Sheets(Sheets.Count)) 116 Range("a1").Resize(UBound(list), 1) = Application.WorksheetFunction.Transpose(list) 117 Range("a1").Resize(UBound(list), 1).Sort key1:=Range("a1") 118 list = Application.WorksheetFunction.Transpose((Range("a1").CurrentRegion.Value)) 119 Sht.Delete 120 Application.DisplayAlerts = True 121 End Sub