他山之石——使用VBA演示排序算法-Part2（插入排序法、希尔排序法和快速排序法）
希尔排序法和快速排序法有点陌生了，学习！
Option Explicit
Sub 插入排序()
Dim arr, temp, x, y, t, iMax, k, k1, k2
t = Timer
arr = Range("a1:a10")
For x = 2 To UBound(arr)
temp = arr(x, 1) '记得要插入的值
For y = x - 1 To 1 Step -1
If arr(y, 1) <= temp Then Exit For
arr(y + 1, 1) = arr(y, 1)
'k1 = k1 + 1
Next y
arr(y + 1, 1) = temp
'k2 = k2 + 1
Next
' Range("d3").Resize(UBound(arr)) = ""
' Range("d3").Resize(UBound(arr)) = arr
'Range("d2") = Timer - t
MsgBox k1
End Sub
Sub 插入排序单元格演示()
On Error Resume Next
Dim arr, temp, x, y, t, iMax, k
For x = 2 To 10
temp = Cells(x, 1) '记得要插入的值
Range("A" & x).Interior.ColorIndex = 3
For y = x - 1 To 1 Step -1
Range("A" & y).Interior.ColorIndex = 4
If Cells(y, 1) <= temp Then Exit For
Cells(y + 1, 1) = Cells(y, 1)
Range("A" & y).Interior.ColorIndex = xlNone
Next y
Cells(y + 1, 1) = temp
Range("A" & y).Interior.ColorIndex = xlNone
Range("A" & x).Interior.ColorIndex = xlNone
Next
End Sub
Sub 希尔排序()
Dim arr
Dim 总大小, 间隔, x, y, temp, t
t = Timer
arr = Range("a1:a30")
总大小 = UBound(arr) - LBound(arr) + 1
间隔 = 1
If 总大小 > 13 Then
Do While 间隔 < 总大小
间隔 = 间隔 * 3 + 1
Loop
间隔 = 间隔 \ 9
End If
' Stop
Do While 间隔
For x = LBound(arr) + 间隔 To UBound(arr)
temp = arr(x, 1)
For y = x - 间隔 To LBound(arr) Step -间隔
If arr(y, 1) <= temp Then Exit For
arr(y + 间隔, 1) = arr(y, 1)
' k1 = k1 + 1
Next y
arr(y + 间隔, 1) = temp
Next x
间隔 = 间隔 \ 3
Loop
' MsgBox k1
'Range("e3").Resize(5000) = ""
Range("d1").Resize(UBound(arr)) = arr
'Range("e2") = Timer - t
End Sub
Sub 打乱顺序()
Dim arr, temp, x
arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
For x = 1 To UBound(arr)
num = Int(Rnd() * UBound(arr) + 1)
temp = arr(num, 1)
arr(num, 1) = arr(x, 1)
arr(x, 1) = temp
Next x
Range("a1").Resize(x - 1) = arr
End Sub
Sub 希尔排序单元格演示()
Dim arr
Dim 总大小, 间隔, x, y, temp, t
t = Timer
arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
总大小 = UBound(arr) - LBound(arr) + 1
间隔 = 1
If 总大小 > 13 Then
Do While 间隔 < 总大小
间隔 = 间隔 * 3 + 1
Loop
间隔 = 间隔 \ 9
End If
' Stop
Do While 间隔
For x = LBound(arr) + 间隔 To UBound(arr)
temp = Cells(x, 1)
Range("a" & x).Interior.ColorIndex = 3
For y = x - 间隔 To LBound(arr) Step -间隔
Range("a" & y).Interior.ColorIndex = 6
If Cells(y, 1) <= temp Then Exit For
Cells(y + 间隔, 1) = Cells(y, 1)
' k1 = k1 + 1
Next y
Cells(y + 间隔, 1) = temp
Range("a1:a30").Interior.ColorIndex = xlNone
Next x
间隔 = 间隔 \ 3
Loop
' MsgBox k1
'Range("e3").Resize(5000) = ""
' Range("d1").Resize(UBound(arr)) = arr
'Range("e2") = Timer - t
End SubOption Explicit
Sub dd()
Dim arr1(0 To 4999) As Long, arr, x, t
t = Timer
arr = Range("a1:a5000")
For x = 1 To 5000
arr1(x - 1) = arr(x, 1)
Next x
QuickSort arr1()
Range("f2") = Timer - t
End Sub
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
Range("f3").Resize(5000) = Application.Transpose(lngArray)
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