为什么会产生用excel来制作排序算法动画的念头，参见【VBA实战】用Excel制作排序算法动画一文。这篇文章贴出我所制作的所有排序算法动画效果和源码，供大家参考。

冒泡排序：

插入排序：

选择排序：

快速排序：

归并排序：

堆排序：

希尔排序：

完整源码如下。大家也可以直接从这儿下载。

Option Explicit
Public hmap As ObjectSub Sleep(t As Single)  ' T 参数的单位是 秒级Dim time1 As Singletime1 = TimerDoDoEvents '转让控制权，以便让操作系统处理其它的事件Loop While Timer - time1 < t  ' T 参数的单位是 秒级
End Sub'移动单元格
Sub CellMoveTo(rs As Integer, cs As Integer, re As Integer, ce As Integer)Worksheets("Sheet2").Cells(rs, cs).SelectSelection.CutWorksheets("Sheet2").Cells(re, ce).SelectActiveSheet.PasteEnd Sub'同一行两个单元格交换
Sub Swap(row As Integer, col1 As Integer, col2 As Integer)Call CellMoveTo(row, col1, row - 2, col1)Call Sleep(1)Call CellMoveTo(row, col2, row - 1, col2)Call Sleep(1)Dim i%, j%i = col1j = col2Do While i < col2Call CellMoveTo(row - 2, i, row - 2, i + 1)i = i + 1Call CellMoveTo(row - 1, j, row - 1, j - 1)j = j - 1Call Sleep(1)LoopCall CellMoveTo(row - 1, col1, row, col1)Call Sleep(1)Call CellMoveTo(row - 2, col2, row, col2)Call Sleep(1)End Sub'堆的节点交换，只交换数字
Sub HeapSwap(c1 As String, c2 As String)Dim n%Dim clr1 As Long, clr2 As Long, clrf As Longclr1 = 5287936clr2 = 49407Call Color2(c1, clr2)Call Color2(c2, clr2)n = Worksheets("Sheet2").Range(c1).ValueWorksheets("Sheet2").Range(c1).Value = Worksheets("Sheet2").Range(c2).ValueWorksheets("Sheet2").Range(c2).Value = nCall Sleep(1)Call Color2(c1, clr1)Call Color2(c2, clr1)End SubSub Color(row As Integer, col As Integer, clr As Long)Worksheets("Sheet2").Cells(row, col).SelectWith Selection.Interior.Pattern = xlSolid.PatternColorIndex = xlAutomatic.Color = clr.TintAndShade = 0.PatternTintAndShade = 0End With
End SubSub Color1(row As Integer, col As Integer, clr As Long)Call Color(row, col, clr)Call Sleep(1)End SubSub Color2(c As String, clr As Long)Worksheets("Sheet2").Range(c).SelectWith Selection.Interior.Pattern = xlSolid.PatternColorIndex = xlAutomatic.Color = clr.TintAndShade = 0.PatternTintAndShade = 0End WithCall Sleep(1)
End SubSub InitData()Dim clr1 As Longclr1 = 5287936Set hmap = CreateObject("Scripting.Dictionary")hmap.Add 5, "M10"hmap.Add 6, "I14"hmap.Add 7, "Q14"hmap.Add 8, "F17"hmap.Add 9, "L17"hmap.Add 10, "N17"hmap.Add 11, "T17"hmap.Add 12, "D19"hmap.Add 13, "H19"hmap.Add 14, "J19"Dim row%, j%row = 7For j = 5 To 14Dim n%n = Int(100 * Rnd)Worksheets("Sheet2").Cells(row, j) = nCall Color(row, j, clr1)Worksheets("Sheet2").Range(hmap.Item(j)).Value = nWorksheets("Sheet2").Range(hmap.Item(j)).SelectSelection.Interior.Color = clr1Next j
End Sub'堆排序Sub Adjust(r As Integer, last As Integer)Dim f1%, f2%, v1%, v2%, row%Dim clr1 As Long, clr2 As Long, clrf As Longclr1 = 5287936clr2 = 49407clrf = 15773696row = 7f1 = 5 + (r - 5) * 2 + 1f2 = 5 + (r - 5) * 2 + 2v1 = -1v2 = -1If f1 <= last Thenv1 = Worksheets("Sheet2").Cells(row, f1).ValueEnd IfIf f2 <= last Thenv2 = Worksheets("Sheet2").Cells(row, f2).ValueEnd IfIf Worksheets("Sheet2").Cells(row, r) < v1 Or Worksheets("Sheet2").Cells(row, r) < v2 ThenDim s%If v1 > v2 Thens = f1Elses = f2End IfCall Color1(row, r, clr2)Call Color1(row, s, clr2)Call Swap(row, r, s)Call Color1(row, r, clr1)Call Color1(row, s, clr1)Call HeapSwap(hmap.Item(r), hmap.Item(s))Call Adjust(s, last)End IfEnd SubSub HeapSort()Dim i%, j%, row%, last%Dim clr1 As Long, clr2 As Long, clrf As Longrow = 7clr1 = 5287936clr2 = 49407clrf = 15773696last = 14For i = 14 To 6 Step -1Dim t%t = 5 + Int((i - 6) / 2)Call Color1(row, i, clr2)Call Color1(row, t, clr2)If Worksheets("Sheet2").Cells(row, i).Value > Worksheets("Sheet2").Cells(row, t).Value ThenCall Swap(row, t, i)Call HeapSwap(hmap.Item(t), hmap.Item(i))Call Adjust(i, last)End IfCall Color1(row, i, clr1)Call Color1(row, t, clr1)Next iFor i = 14 To 6 Step -1Call Color1(row, 5, clr2)Call Color1(row, i, clr2)Call Swap(row, 5, i)Call Color1(row, 5, clr1)Call Color1(row, i, clrf)Call HeapSwap(hmap.Item(5), hmap.Item(i))Call Color2(hmap.Item(i), clrf)last = last - 1Call Adjust(5, last)Next iCall Color1(row, 5, clrf)Call Color2(hmap.Item(5), clrf)
End Sub'希尔排序
Sub ShellSort()Dim i%, j%, row%, gap%, tmp%Dim clr1 As Long, clr2 As Long, clrf As Longrow = 7clr1 = 5287936clr2 = 49407clrf = 15773696gap = 5Do While gap > 0For i = 5 + gap To 14tmp = Worksheets("Sheet2").Cells(row, i).ValueCall Color1(row, i, clr2)Call CellMoveTo(row, i, row - 2, i)Call Sleep(1)For j = i - gap To 5 Step -gapCall Color1(row, j, clr2)If tmp < Worksheets("Sheet2").Cells(row, j).Value ThenCall CellMoveTo(row, j, row, j + gap)Call Sleep(1)Call Color1(row, j + gap, clr1)Call CellMoveTo(row - 2, j + gap, row - 2, j)Call Sleep(1)ElseCall Color1(row, j, clr1)Exit ForEnd IfNext jCall CellMoveTo(row - 2, j + gap, row, j + gap)Call Sleep(1)Call Color1(row, j + gap, clr1)Next igap = Int(gap / 2)LoopEnd Sub'归并排序
Sub Merge(s1 As Integer, e1 As Integer, s2 As Integer, e2 As Integer)Dim i%, j%, p%, row%Dim clr1 As Long, clr2 As Long, clr3 As Long, clrf As Longrow = 7clr1 = 5287936clr2 = 49407clr3 = 65535clrf = 15773696For i = s1 To e1Call Color(row, i, clr2)Next iFor i = s2 To e2Call Color(row, i, clr3)Next iCall Sleep(1)i = s1j = s2p = s1Do While i <= e1 And j <= e2Do While i <= e1 And Worksheets("Sheet2").Cells(row, i).Value <= Worksheets("Sheet2").Cells(row, j).ValueCall CellMoveTo(row, i, row - 2, p)Call Sleep(1)p = p + 1i = i + 1LoopDo While j <= e2 And Worksheets("Sheet2").Cells(row, j).Value < Worksheets("Sheet2").Cells(row, i).ValueCall CellMoveTo(row, j, row - 2, p)Call Sleep(1)p = p + 1j = j + 1LoopLoopDo While i <= e1Call CellMoveTo(row, i, row - 2, p)Call Sleep(1)p = p + 1i = i + 1LoopDo While j <= e2Call CellMoveTo(row, j, row - 2, p)Call Sleep(1)p = p + 1j = j + 1LoopFor i = s1 To e2Call Color(row - 2, i, clr1)Call CellMoveTo(row - 2, i, row, i)Next iCall Sleep(1)End SubSub MergeSort2(left As Integer, right As Integer)Dim mid%If left >= right ThenExit SubEnd Ifmid = Int((left + right) / 2)Call MergeSort2(left, mid)Call MergeSort2(mid + 1, right)Call Merge(left, mid, mid + 1, right)End SubSub MergeSort()Call MergeSort2(5, 14)
End Sub'快速排序
Sub QuickSort(low As Integer, high As Integer)Dim left%, right%, mend%, row%, i%Dim clr1 As Long, clr2 As Long, clr3 As Long, clrf As Longmend = 14row = 7clr1 = 5287936clr2 = 49407clr3 = 65535clrf = 15773696For i = low To highCall Color(row, i, clr3)Next iCall Sleep(1)If low >= high ThenIf low = high ThenCall Color1(row, low, clrf)End IfExit SubEnd Ifleft = low + 1right = highCall Color1(row, low, clrf)Do While left <= rightCall Color1(row, left, clr2)Do While left <= right And Worksheets("Sheet2").Cells(row, left).Value <= Worksheets("Sheet2").Cells(row, low).ValueCall Color1(row, left, clr1)left = left + 1If left <= right ThenCall Color1(row, left, clr2)End IfLoopCall Color1(row, right, clr2)Do While left <= right And Worksheets("Sheet2").Cells(row, right).Value > Worksheets("Sheet2").Cells(row, low).ValueCall Color1(row, right, clr1)right = right - 1If right >= left ThenCall Color1(row, right, clr2)End IfLoopIf left < right ThenCall Color(row, right, clr2)Call Swap(row, left, right)Call Color(row, left, clr3)Call Color(row, right, clr3)Call Sleep(1)End IfLoopIf low <> left - 1 ThenCall Swap(row, low, left - 1)End IfCall QuickSort(low, left - 2)Call QuickSort(left, high)
End SubSub QuickSort2()Call QuickSort(5, 14)
End Sub'选择排序
Sub SelectionSort()Dim i%, j%, min%, row%Dim clr1 As Long, clr2 As Long, clrf As Long'mend = 14row = 7clr1 = 5287936clr2 = 49407clrf = 15773696For i = 5 To 13min = iCall Color1(row, min, clrf)For j = i + 1 To 14Call Color(row, j, clr2)Call Sleep(1)If Worksheets("Sheet2").Cells(row, j).Value < Worksheets("Sheet2").Cells(row, min).Value ThenCall Color1(row, j, clrf)Call Color1(row, min, clr1)min = jElseCall Color1(row, j, clr1)End IfNext jIf min <> i ThenCall Swap(row, i, min)Call Sleep(1)End IfNext iCall Color(row, 14, clrf)
End Sub'插入排序
Sub InsertSort()Dim i%, j%, row%, tmp%Dim clr1 As Long, clr2 As Long, clrf As Longrow = 7clr1 = 5287936clr2 = 49407clrf = 15773696For i = 6 To 14tmp = Worksheets("Sheet2").Cells(row, i).ValueCall Color1(row, i, clr2)Call CellMoveTo(row, i, row - 1, i)Call Sleep(1)For j = i - 1 To 5 Step -1Call Color1(row, j, clr2)If tmp < Worksheets("Sheet2").Cells(row, j).Value ThenCall CellMoveTo(row, j, row, j + 1)Call Sleep(1)Call Color1(row, j + 1, clr1)Call CellMoveTo(row - 1, j + 1, row - 1, j)Call Sleep(1)ElseCall Color1(row, j, clr1)Exit ForEnd IfNext jCall CellMoveTo(row - 1, j + 1, row, j + 1)Call Sleep(1)Call Color1(row, j + 1, clr1)Next iEnd Sub'冒泡排序
Sub BubbleSort()Dim i%, j%, mend%, row%Dim clr1 As Long, clr2 As Long, clrf As Longmend = 14row = 7clr1 = 5287936clr2 = 49407clrf = 15773696For i = 5 To 13For j = 5 To mend - 1Call Color(row, j, clr2)Call Color(row, j + 1, clr2)Call Sleep(1)If Worksheets("Sheet2").Cells(row, j).Value > Worksheets("Sheet2").Cells(row, j + 1).Value ThenCall Swap(row, j, j + 1)End IfCall Color(row, j, clr1)Call Color(row, j + 1, clr1)Call Sleep(1)Next jCall Color(row, mend, clrf)mend = mend - 1Call Sleep(1)Next iCall Color(row, mend, clrf)End Sub