【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
相关推荐
汝即来归9 小时前
选择排序和冒泡排序；MySQL架构
数据结构·算法·排序算法
光头man13 小时前
【八大排序(二)】希尔排序
算法·排序算法
不吃鱼的羊14 小时前
Excel生成DBC脚本源文件
服务器·网络·excel
chenchihwen14 小时前
数据分析时的json to excel 转换的好用小工具
数据分析·json·excel
云边有个稻草人16 小时前
【优选算法】—移动零（双指针算法）
算法·排序算法·双指针算法
lxxxxl16 小时前
C#调用OpenXml，读取excel行数据，遇到空单元跳过现象处理
excel
m0_7482463517 小时前
前端通过new Blob下载文档流（下载zip或excel）
前端·excel
不吃鱼不吃鱼1 天前
Excel加载项入门：原理、安装卸载流程与常见问题
excel·wps
深耕AI1 天前
在Excel中绘制ActiveX控件：解决文本编辑框定位问题
java·前端·excel
热门推荐
01〔AI 绘画〕Stable Diffusion 之 解决绘制多人或面部很小的人物时面部崩坏问题 篇02YOLOv8训练好模型后，追加轮数继续训练、或者提前终止训练，缩减训练轮数03玄机平台应急响应—webshell查杀04DisplayPort AltMode On Type-c协议_Ver2.0(学习笔记)05HCIA-datacom数通题库和录播视频资料06Docker 夺命连环 15 问076个主流的工业3D管道设计软件08校验 GPT-4 真实性的三个经典问题：快速区分 GPT-3.5 与 GPT-4，并提供免费测试网站09(欧拉)openEuler系统添加网卡文件配置流程、(欧拉)openEuler系统手动配置ipv6地址流程、(欧拉)openEuler系统网络管理说明10树莓派 5 AI 套件（Hailo-8L）使用教程