前段时间，领导让对某个活动的人员进行抽签排序后参加活动，于是借助AI写了这么一个程序，跟大家共享。这里面A列是抽签号，B列是姓名，让姓名进行随机滚动，最后形成新的排序。
Dim isRunning As Boolean
Dim stopTime As Double
Dim scrollSpeed As Double
Dim lastRow As Long ' 将lastRow声明为模块级变量
Sub StartScrolling()
' 设置滚动速度(秒)，数值越小滚动越快
scrollSpeed = 0.1
isRunning = True
stopTime = Now + TimeSerial(0, 0, 10) ' 10秒后自动停止
' 禁用自动计算和事件以提高性能，但保持屏幕更新
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = True ' 保持屏幕更新以看到滚动效果
' 开始滚动
Do While isRunning And Now < stopTime
Randomize
With ActiveSheet
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
' 随机排序B列数据（从第2行开始）
Dim arr() As Variant
If lastRow > 1 Then
arr = .Range("B2:B" & lastRow).Value
' Fisher-Yates洗牌算法
Dim i As Long, j As Long, temp As Variant
For i = UBound(arr, 1) To 2 Step -1
j = Int((i - 1) * Rnd) + 1
temp = arr(i, 1)
arr(i, 1) = arr(j, 1)
arr(j, 1) = temp
Next i
' 直接在B列更新并设置格式
With .Range("B2").Resize(UBound(arr, 1), 1)
.Value = arr
.Font.Color = RGB(255, 0, 0) ' 红色字体
.Font.Bold = True ' 加粗
End With
End If
End With
' 控制滚动速度并保持响应
Dim startTime As Double
startTime = Timer
Do While (Timer - startTime) < scrollSpeed And isRunning
DoEvents ' 关键点：允许处理其他事件
If Not isRunning Then Exit Do
Loop
If Not isRunning Then Exit Do
Loop
' 恢复Excel设置
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
' 停止后保持当前随机结果（不再恢复原始数据）
If Now >= stopTime Then
MsgBox "滚动已完成！最终结果已保留。", vbInformation
' 保持当前随机排序结果
With ActiveSheet
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
' 保留红色加粗字体或恢复默认格式（根据需要选择）
' 如果要恢复默认格式，取消下面三行注释
'.Range("B2:B" & lastRow).Font.Color = RGB(0, 0, 0) ' 恢复黑色
'.Range("B2:B" & lastRow).Font.Bold = False ' 取消加粗
End With
End If
End Sub
Sub StopScrolling()
isRunning = False
DoEvents
End Sub
以上仅供参考。