前段时间，领导让对某个活动的人员进行抽签排序后参加活动，于是借助AI写了这么一个程序，跟大家共享这里面A列是抽签号，B列是姓名，让姓名进行随机滚动，最后形成新的排序Dim isRunning As Boolean。

Dim stopTime As DoubleDim scrollSpeed As DoubleDim lastRow As Long 将lastRow声明为模块级变量Sub StartScrolling()

设置滚动速度(秒)，数值越小滚动越快scrollSpeed = 0.1isRunning = TruestopTime = Now + TimeSerial(0, 0, 10) 10秒后自动停止 禁用自动计算和事件以提高性能，但保持屏幕更新

Application.Calculation = xlCalculationManualApplication.EnableEvents = FalseApplication.ScreenUpdating = True 保持屏幕更新以看到滚动效果

开始滚动Do While isRunning And Now < stopTimeRandomizeWith ActiveSheetlastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

随机排序B列数据（从第2行开始）Dim arr() As VariantIf lastRow > 1 Thenarr = .Range("B2:B" & lastRow).Value Fisher-Yates洗牌算法

Dim i As Long, j As Long, temp As VariantFor i = UBound(arr, 1) To 2 Step -1j = Int((i - 1) * Rnd) + 1

temp = arr(i, 1)arr(i, 1) = arr(j, 1)arr(j, 1) = tempNext i 直接在B列更新并设置格式With .Range("B2").Resize(UBound(arr, 1), 1)

.Value = arr.Font.Color = RGB(255, 0, 0) 红色字体.Font.Bold = True 加粗End WithEnd IfEnd With 控制滚动速度并保持响应

Dim startTime As DoublestartTime = TimerDo While (Timer - startTime) < scrollSpeed And isRunningDoEvents 关键点：允许处理其他事件

If Not isRunning Then Exit DoLoopIf Not isRunning Then Exit DoLoop 恢复Excel设置Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomaticApplication.EnableEvents = True 停止后保持当前随机结果（不再恢复原始数据）

If Now >= stopTime ThenMsgBox "滚动已完成！最终结果已保留", vbInformation 保持当前随机排序结果With ActiveSheetlastRow = .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 WithEnd IfEnd SubSub StopScrolling()isRunning = FalseDoEventsEnd Sub以上仅供参考。