为什么会产生用excel来制作排序算法动画的念头，参见【VBA实战】用Excel制作排序算法动画一文。这篇文章贴出我所制作的所有排序算法动画效果和源码，供大家参考。
冒泡排序：
插入排序：
选择排序：
快速排序：
归并排序：
堆排序：
希尔排序：
完整源码如下。大家也可以直接从这儿下载。
Option Explicit
Public hmap As Object
Sub Sleep(t As Single) ' T 参数的单位是 秒级
Dim time1 As Single
time1 = Timer
Do
DoEvents '转让控制权，以便让操作系统处理其它的事件
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).Select
Selection.Cut
Worksheets("Sheet2").Cells(re, ce).Select
ActiveSheet.Paste
End 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 = col1
j = col2
Do While i < col2
Call CellMoveTo(row - 2, i, row - 2, i + 1)
i = i + 1
Call CellMoveTo(row - 1, j, row - 1, j - 1)
j = j - 1
Call Sleep(1)
Loop
Call 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 Long
clr1 = 5287936
clr2 = 49407
Call Color2(c1, clr2)
Call Color2(c2, clr2)
n = Worksheets("Sheet2").Range(c1).Value
Worksheets("Sheet2").Range(c1).Value = Worksheets("Sheet2").Range(c2).Value
Worksheets("Sheet2").Range(c2).Value = n
Call Sleep(1)
Call Color2(c1, clr1)
Call Color2(c2, clr1)
End Sub
Sub Color(row As Integer, col As Integer, clr As Long)
Worksheets("Sheet2").Cells(row, col).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = clr
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Sub Color1(row As Integer, col As Integer, clr As Long)
Call Color(row, col, clr)
Call Sleep(1)
End Sub
Sub Color2(c As String, clr As Long)
Worksheets("Sheet2").Range(c).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = clr
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Call Sleep(1)
End Sub
Sub InitData()
Dim clr1 As Long
clr1 = 5287936
Set 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 = 7
For j = 5 To 14
Dim n%
n = Int(100 * Rnd)
Worksheets("Sheet2").Cells(row, j) = n
Call Color(row, j, clr1)
Worksheets("Sheet2").Range(hmap.Item(j)).Value = n
Worksheets("Sheet2").Range(hmap.Item(j)).Select
Selection.Interior.Color = clr1
Next 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 Long
clr1 = 5287936
clr2 = 49407
clrf = 15773696
row = 7
f1 = 5 + (r - 5) * 2 + 1
f2 = 5 + (r - 5) * 2 + 2
v1 = -1
v2 = -1
If f1 <= last Then
v1 = Worksheets("Sheet2").Cells(row, f1).Value
End If
If f2 <= last Then
v2 = Worksheets("Sheet2").Cells(row, f2).Value
End If
If Worksheets("Sheet2").Cells(row, r) < v1 Or Worksheets("Sheet2").Cells(row, r) < v2 Then
Dim s%
If v1 > v2 Then
s = f1
Else
s = f2
End If
Call 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 If
End Sub
Sub HeapSort()
Dim i%, j%, row%, last%
Dim clr1 As Long, clr2 As Long, clrf As Long
row = 7
clr1 = 5287936
clr2 = 49407
clrf = 15773696
last = 14
For i = 14 To 6 Step -1
Dim 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 Then
Call Swap(row, t, i)
Call HeapSwap(hmap.Item(t), hmap.Item(i))
Call Adjust(i, last)
End If
Call Color1(row, i, clr1)
Call Color1(row, t, clr1)
Next i
For i = 14 To 6 Step -1
Call 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 - 1
Call Adjust(5, last)
Next i
Call 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 Long
row = 7
clr1 = 5287936
clr2 = 49407
clrf = 15773696
gap = 5
Do While gap > 0
For i = 5 + gap To 14
tmp = Worksheets("Sheet2").Cells(row, i).Value
Call Color1(row, i, clr2)
Call CellMoveTo(row, i, row - 2, i)
Call Sleep(1)
For j = i - gap To 5 Step -gap
Call Color1(row, j, clr2)
If tmp < Worksheets("Sheet2").Cells(row, j).Value Then
Call 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)
Else
Call Color1(row, j, clr1)
Exit For
End If
Next j
Call CellMoveTo(row - 2, j + gap, row, j + gap)
Call Sleep(1)
Call Color1(row, j + gap, clr1)
Next i
gap = Int(gap / 2)
Loop
End 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 Long
row = 7
clr1 = 5287936
clr2 = 49407
clr3 = 65535
clrf = 15773696
For i = s1 To e1
Call Color(row, i, clr2)
Next i
For i = s2 To e2
Call Color(row, i, clr3)
Next i
Call Sleep(1)
i = s1
j = s2
p = s1
Do While i <= e1 And j <= e2
Do While i <= e1 And Worksheets("Sheet2").Cells(row, i).Value <= Worksheets("Sheet2").Cells(row, j).Value
Call CellMoveTo(row, i, row - 2, p)
Call Sleep(1)
p = p + 1
i = i + 1
Loop
Do While j <= e2 And Worksheets("Sheet2").Cells(row, j).Value < Worksheets("Sheet2").Cells(row, i).Value
Call CellMoveTo(row, j, row - 2, p)
Call Sleep(1)
p = p + 1
j = j + 1
Loop
Loop
Do While i <= e1
Call CellMoveTo(row, i, row - 2, p)
Call Sleep(1)
p = p + 1
i = i + 1
Loop
Do While j <= e2
Call CellMoveTo(row, j, row - 2, p)
Call Sleep(1)
p = p + 1
j = j + 1
Loop
For i = s1 To e2
Call Color(row - 2, i, clr1)
Call CellMoveTo(row - 2, i, row, i)
Next i
Call Sleep(1)
End Sub
Sub MergeSort2(left As Integer, right As Integer)
Dim mid%
If left >= right Then
Exit Sub
End If
mid = Int((left + right) / 2)
Call MergeSort2(left, mid)
Call MergeSort2(mid + 1, right)
Call Merge(left, mid, mid + 1, right)
End Sub
Sub 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 Long
mend = 14
row = 7
clr1 = 5287936
clr2 = 49407
clr3 = 65535
clrf = 15773696
For i = low To high
Call Color(row, i, clr3)
Next i
Call Sleep(1)
If low >= high Then
If low = high Then
Call Color1(row, low, clrf)
End If
Exit Sub
End If
left = low + 1
right = high
Call Color1(row, low, clrf)
Do While left <= right
Call Color1(row, left, clr2)
Do While left <= right And Worksheets("Sheet2").Cells(row, left).Value <= Worksheets("Sheet2").Cells(row, low).Value
Call Color1(row, left, clr1)
left = left + 1
If left <= right Then
Call Color1(row, left, clr2)
End If
Loop
Call Color1(row, right, clr2)
Do While left <= right And Worksheets("Sheet2").Cells(row, right).Value > Worksheets("Sheet2").Cells(row, low).Value
Call Color1(row, right, clr1)
right = right - 1
If right >= left Then
Call Color1(row, right, clr2)
End If
Loop
If left < right Then
Call Color(row, right, clr2)
Call Swap(row, left, right)
Call Color(row, left, clr3)
Call Color(row, right, clr3)
Call Sleep(1)
End If
Loop
If low <> left - 1 Then
Call Swap(row, low, left - 1)
End If
Call QuickSort(low, left - 2)
Call QuickSort(left, high)
End Sub
Sub 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 = 14
row = 7
clr1 = 5287936
clr2 = 49407
clrf = 15773696
For i = 5 To 13
min = i
Call Color1(row, min, clrf)
For j = i + 1 To 14
Call Color(row, j, clr2)
Call Sleep(1)
If Worksheets("Sheet2").Cells(row, j).Value < Worksheets("Sheet2").Cells(row, min).Value Then
Call Color1(row, j, clrf)
Call Color1(row, min, clr1)
min = j
Else
Call Color1(row, j, clr1)
End If
Next j
If min <> i Then
Call Swap(row, i, min)
Call Sleep(1)
End If
Next i
Call Color(row, 14, clrf)
End Sub
'插入排序
Sub InsertSort()
Dim i%, j%, row%, tmp%
Dim clr1 As Long, clr2 As Long, clrf As Long
row = 7
clr1 = 5287936
clr2 = 49407
clrf = 15773696
For i = 6 To 14
tmp = Worksheets("Sheet2").Cells(row, i).Value
Call Color1(row, i, clr2)
Call CellMoveTo(row, i, row - 1, i)
Call Sleep(1)
For j = i - 1 To 5 Step -1
Call Color1(row, j, clr2)
If tmp < Worksheets("Sheet2").Cells(row, j).Value Then
Call 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)
Else
Call Color1(row, j, clr1)
Exit For
End If
Next j
Call CellMoveTo(row - 1, j + 1, row, j + 1)
Call Sleep(1)
Call Color1(row, j + 1, clr1)
Next i
End Sub
'冒泡排序
Sub BubbleSort()
Dim i%, j%, mend%, row%
Dim clr1 As Long, clr2 As Long, clrf As Long
mend = 14
row = 7
clr1 = 5287936
clr2 = 49407
clrf = 15773696
For i = 5 To 13
For j = 5 To mend - 1
Call 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 Then
Call Swap(row, j, j + 1)
End If
Call Color(row, j, clr1)
Call Color(row, j + 1, clr1)
Call Sleep(1)
Next j
Call Color(row, mend, clrf)
mend = mend - 1
Call Sleep(1)
Next i
Call Color(row, mend, clrf)
End Sub
