他山之石——使用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 Sub

Option 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