【VBA实战】用Excel制作排序算法动画续

lc寒曦2024-11-10 8:56

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

冒泡排序：

插入排序：

选择排序：

快速排序：

归并排序：

堆排序：

希尔排序：

完整源码如下。

vbnet 复制代码 
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
相关推荐
是希燃亚2 天前
📚 十大经典排序算法 C语言笔记（一看就会版）
排序算法
LAM LAB4 天前
【VBA】Excel指定单元格范围内字体设置样式，处理导出课表单元格
excel·vba
在这habit之下4 天前
Keepalived学习总结
excel
Youngchatgpt4 天前
如何在 Excel 中使用 ChatGPT：自动化任务和编写公式
人工智能·chatgpt·自动化·excel
开开心心就好4 天前
安卓开源应用，超时提醒紧急人护独居安全
windows·决策树·计算机视觉·pdf·计算机外设·excel·动态规划
D_C_tyu4 天前
Vue3 + Element Plus | el-table 多级表头表格导出 Excel（含合并单元格、单元格居中）第二版
vue.js·elementui·excel
2501_924878734 天前
AI如何打通前端、后端、UI、SEO、文档等12类办公链路？
逻辑回归·排序算法
历程里程碑4 天前
26信号处理一：从闹钟到进程控制的奥秘
linux·运维·服务器·开发语言·c++·算法·排序算法
载数而行5204 天前
算法系列4之插入排序
数据结构·c++·算法·排序算法
热门推荐
01GitHub 镜像站点02OpenClaw 使用和管理 MCP 完全指南03OpenClaw + 飞书（Feishu）环境搭建指南04【OpenClaw 本地实战 Ep.3】突破瓶颈：强制修改 openclaw.json 解锁 32k 上下文记忆05Claude Code + GLM4.7 避坑指南：解决 Unable to connect to Anthropic services06OpenClaw优化飞书API 额度已耗尽问题07Clawdbot部署教程：解决‘gateway token missing’授权问题的完整步骤08OpenClaw大龙虾机器人完整安装教程09小黑课堂计算机二级WPSoffice题库软件下载安装教程（2026年3月最新版）10Window 10部署openclaw报错node.exe : npm error code 128