【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
相关推荐
励志成为嵌入式工程师40 分钟前
c语言选择排序
c语言·算法·排序算法
三小尛42 分钟前
希尔排序（C语言）
c语言·数据结构·排序算法
还在学习进步3 小时前
C语言第十一周课——函数的调用
c语言·算法·排序算法
璇嘟嘟4 小时前
excel-VLOOKUP函数使用/XVLOOKUP使用
excel
图片转成excel表格13 小时前
Excel中快速计算服务天数的操作指导
excel
ruleslol14 小时前
VBA10-处理Excel的动态数据区域
excel·vba
我是聪明的懒大王懒洋洋15 小时前
算法导论第二章
算法·排序算法
颖火虫-IT赵云15 小时前
json转excel，读取json文件写入到excel中【rust语言】
rust·json·excel·jsontoexcel
irisart16 小时前
9 ＞ 数据结构与算法 排序
数据结构·算法·排序算法
hard_coding_wang18 小时前
AI生活之我用AI处理Excel表格
人工智能·excel
热门推荐
01聊聊 Python 中的同步原语，为什么有了 GIL 还需要同步原语02【HarmonyOS】HUAWEI DevEco Studio 下载地址汇总03Windows10安装PCL1.14.0及点云配准04VSCode插件 —— Cody AI （免费AI助手！）05全面解析：构建基于深度学习的安全帽检测系统（UI界面+YOLO代码+数据集）06组基轨迹建模 GBTM的介绍与实现（Stata 或 R）07Ubuntu 20.04使用Livox mid 360 测试 FAST_LIO08基于YOLOv10深度学习的CT扫描图像肾结石智能检测系统【python源码+Pyqt5界面+数据集+训练代码】深度学习实战、目标检测09Coze扣子平台完整体验和实践（附国内和国际版对比）10C++——超强级病毒代码