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

为什么会产生用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
相关推荐
SunkingYang15 小时前
详细介绍C++中通过OLE操作excel时,一般会出现哪些异常,这些异常的原因是什么,如何来解决这些异常
c++·excel·解决方案·闪退·ole·异常类型·异常原因
Wu_hello_mi15 小时前
Excel使用教程笔记
笔记·excel
恶猫16 小时前
Polaris Officev9.9.12全功能解锁版
pdf·word·excel·ppt·office·办公·打工
杂货铺的小掌柜17 小时前
apache poi excel 字体数量限制
java·excel·poi
东方佑1 天前
基于FastAPI与LangChain的Excel智能数据分析API开发实践
langchain·excel·fastapi
许泽宇的技术分享1 天前
当Excel遇上大语言模型:ExcelAgentTemplate架构深度剖析与实战指南
语言模型·架构·excel
gihigo19981 天前
基于MATLAB的Excel文件批量读取与循环处理
matlab·excel
Access开发易登软件2 天前
Access调用Azure翻译:轻松实现系统多语言切换
后端·python·低代码·flask·vba·access·access开发
Da Da 泓2 天前
shellSort
java·数据结构·学习·算法·排序算法