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

news2024/11/12 14:12:16

为什么会产生用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


本文来自互联网用户投稿,该文观点仅代表作者本人,不代表本站立场。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如若转载,请注明出处:http://www.coloradmin.cn/o/2237377.html

如若内容造成侵权/违法违规/事实不符,请联系多彩编程网进行投诉反馈,一经查实,立即删除!

相关文章

关于Markdown的一点疑问,为什么很多人说markdown比word好用?

markdown和word压根不是一类工具&#xff0c;不存在谁比谁好&#xff0c;只是应用场景不一样。 你写博客、写readme肯定得markdown&#xff0c;但写合同、写简历肯定word更合适。 markdown和word类似邮箱和微信的关系&#xff0c;这两者都可以通信&#xff0c;但微信因为功能…

区块链技术在数字版权管理中的应用

&#x1f493; 博客主页&#xff1a;瑕疵的CSDN主页 &#x1f4dd; Gitee主页&#xff1a;瑕疵的gitee主页 ⏩ 文章专栏&#xff1a;《热点资讯》 区块链技术在数字版权管理中的应用 区块链技术在数字版权管理中的应用 区块链技术在数字版权管理中的应用 引言 区块链技术概述 …

基于Spring Boot的在线装修管理系统的设计与实现,LW+源码+讲解

摘 要 互联网发展至今&#xff0c;无论是其理论还是技术都已经成熟&#xff0c;而且它广泛参与在社会中的方方面面。它让信息都可以通过网络传播&#xff0c;搭配信息管理工具可以很好地为人们提供服务。针对信息管理混乱&#xff0c;出错率高&#xff0c;信息安全性差&#…

Ollama 0.4 发布!支持 Llama 3.2 Vision,实现多模态 RAG

“ 阅读本文大概需要5分钟。 前言 最近&#xff0c;Ollama 推出了 0.4 版本&#xff0c;其中最大的亮点就是支持了 Llama 3.2 Vision 模型&#xff0c;该模型具备多模态特性&#xff0c;也就是说能够理解图像并将图像纳入提示词中进行处理&#xff0c;让模型更智能地处理RAG中…

关于若依500验证码问题的求助

关于若依框架中验证码出现500错误的问题&#xff0c;这通常表示服务器内部错误。以下是一些可能的原因及解决方案&#xff1a; 一、配置文件问题 .env.production文件&#xff1a; 确保.env.production文件中的VUE_APP_BASE_API已经修改成服务器上的域名地址&#xff0c;而不…

使用HtmlAgilityPack+PuppeteerSharp+iText7抓取IdentityServer4帮助文档

需要学习IdentityServer4的用法&#xff0c;但是在IdentityServer4帮助文档网站&#xff08;参考文献1&#xff09;中没有找到下载离线文档的地方&#xff0c;准备使用HtmlAgilityPackPuppeteerSharpiText7将网站内容抓取生成离线PDF文档&#xff0c;便于本机学习、查看。   …

fpga开发原理图设计仿真分析

目录 原理图设计方法的流程 仿真分析 method1. 基于向量波形的仿真方法 method2. 基于testbench的仿真方法 在Quartus Prime开发环境下&#xff0c;进行EDA设计的基本流程如图所示。 包括五个主要任务: (1) 建立工程 (2) 设计输入 (3) 编译、综合与适配 (4) 引脚…

Node.js——fs模块-路径补充说明

1、相对路径&#xff1a; ./座右铭.txt 当前目录下的座右铭.txt座右铭.txt 等效于上面的写法../座右铭.txt 当前目录的上一级目录中的座右铭.txt 2、绝对路径 D&#xff1a;/Program File Windows系统下的绝对路径/usr/bin Linux系统…

从0开始搭建一个生产级SpringBoot2.0.X项目(十)SpringBoot 集成RabbitMQ

前言 最近有个想法想整理一个内容比较完整springboot项目初始化Demo。 SpringBoot集成RabbitMQ RabbitMQ中的一些角色&#xff1a; publisher&#xff1a;生产者 consumer&#xff1a;消费者 exchange个&#xff1a;交换机&#xff0c;负责消息路由 queue&#xff1a;队列…

比流计算资源效率最高提升 1000 倍,“增量计算”新模式能否颠覆数据分析?

作者 | 关涛 云器科技CTO 数据平台领域发展 20 年&#xff0c;逐渐成为每个企业的基础设施。作为一个进入“普惠期”的领域&#xff0c;当下的架构已经完美了吗&#xff0c;主要问题和挑战是什么&#xff1f;在 2023 年 AI 跃变式爆发的大背景下&#xff0c;数据平台又该如何演…

MySQL性能测试方案设计

在现代互联网系统中&#xff0c;数据库性能直接影响到整体应用的速度和用户体验。而MySQL作为广泛使用的关系型数据库&#xff0c;随着数据量和并发请求的增长&#xff0c;其性能问题也日益突出。今天我们将深入探讨如何设计一套高效的MySQL性能测试方案&#xff0c;帮助你精准…

彻底解决单片机BootLoader升级程序失败问题

文章目录 1、引言2、MicroBoot&#xff1a;优雅的解决升级问题问题1&#xff1a;bootloader 在跳转到app前没有清理干净存在的痕迹问题2&#xff1a; 需要 APP 传递信息给 Bootloader问题3&#xff1a; APP单独运行没有问题&#xff0c;通过Bootloader跳转到APP运行莫名死机问题…

Oracle OCP认证考试考点详解082系列17

题记&#xff1a; 本系列主要讲解Oracle OCP认证考试考点&#xff08;题目&#xff09;&#xff0c;适用于19C/21C,跟着学OCP考试必过。 81. 第81题&#xff1a; 题目 81.Examine these SOL statements which execute successfully Which two statements are true after exec…

【EFK】Linux集群部署Elasticsearch最新版本8.x

【EFK】Linux集群部署Elasticsearch最新版本8.x 摘要环境准备环境信息系统初始化启动先决条件 下载&安装修改elasticsearch.yml控制台启动Linux服务启动访问验证查看集群信息查看es健康状态查看集群节点查询集群状态 生成service token验证service tokenIK分词器下载 摘要 …

基于python的天气数据采集与可视化分析,对20个城市的天气适宜出行度分析

摘要 本项目旨在基于Python对20个城市的天气数据进行采集与可视化分析&#xff0c;以评估天气的适宜出行度。该分析通过四个主要指标进行量化&#xff0c;这些指标分别是天气状况良好率、空气质量优良率、气温适宜率和安全天气率。通过这些指标&#xff0c;我们能够有效地判断…

外贸管理利器7选,助力高效办公

推荐7款外贸管理软件&#xff0c;包括ZohoBooks、ZohoCRM、富通天下等&#xff0c;各具特色&#xff0c;满足外贸企业不同需求&#xff0c;提高管理效率&#xff0c;助力企业全球化竞争。、 一、Zoho Books Zoho Books是一款外贸财务管理软件&#xff0c;不仅为用户提供了一个…

【JWT】Asp.Net Core中JWT刷新Token解决方案

Asp.Net Core中JWT刷新Token解决方案 前言方案一:当我们操作某个需要token作为请求头的接口时,返回的数据错误error.response.status === 401,说明我们的token已经过期了。方案二:实现用户无感知的刷新token值,我们希望当响应返回的数据是401身份过期时,响应阻拦器自动帮我…

当AI遇上时尚:未来的衣橱会由机器人来打理吗?

内容概要 在当今这个快速发展的时代&#xff0c;人工智能与时尚的结合正在逐渐改写我们对衣橱管理的认知。传统的衣橱管理常常面临着空间不足、穿搭单调及库存过多等挑战&#xff0c;许多人在挑选服饰时难以做出决策。然而&#xff0c;随着技术的进步&#xff0c;智能推荐和自…

编写虚拟的GPIO控制器的驱动程序:和pinctrl的交互使用

往期内容 本专栏往期内容&#xff1a; Pinctrl子系统和其主要结构体引入Pinctrl子系统pinctrl_desc结构体进一步介绍Pinctrl子系统中client端设备树相关数据结构介绍和解析inctrl子系统中Pincontroller构造过程驱动分析&#xff1a;imx_pinctrl_soc_info结构体Pinctrl子系统中c…

【MySQL】数据库整合攻略 :表操作技巧与详解

前言&#xff1a;本节内容讲述表的操作&#xff0c; 对表结构的操作。 是对表结构中的字段的增删查改以及表本身的创建以及删除。 ps&#xff1a;本节内容本节内容适合安装了MySQL的友友们进行观看&#xff0c; 实操更有利于记住哦。 目录 创建表 查看表结构 修改表结构 …