在excel中进行抽签摇号

前段时间，领导让对某个活动的人员进行抽签排序后参加活动，于是借助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

以上仅供参考。