技术宅的浪漫:用Excel VBA实现放鞭炮效果,祝大家马年红红火火

Option Explicit' 声明 Sleep API（用于毫秒级延时）#If VBA7 Then    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)#Else    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)#End IfSub Firecracker()    Dim rng As Range    Dim i As Long, j As Long    Dim totalShots As Long    Dim shotCount As Long    Dim cellsPerShot As Integer    Dim cellRows As Long, cellCols As Long    Dim origColors() As Variant    Dim lastAffected As Range    Dim currentAffected As Range    Dim rowIndex As Long, colIndex As Long    Dim randRow As Long, randCol As Long    Dim k As Integer    Dim color As Long    Dim cell As Range    ' 让用户选择燃放区域    On Error Resume Next    Set rng = Sheet1.Range(" A1: ak34")    On Error GoTo 0    If rng Is Nothing Then Exit Sub    ' 初始化随机数生成器    Randomize    ' 保存区域原始颜色到数组    cellRows = rng.Rows.Count    cellCols = rng.Columns.Count    ReDim origColors(1 To cellRows, 1 To cellCols)    For i = 1 To cellRows        For j = 1 To cellCols            origColors(i, j) = rng.Cells(i, j).Interior.color        Next j    Next i    ' 关闭屏幕更新，提高执行速度（之后会按需刷新）    Application.ScreenUpdating = False    totalShots = 40          ' 总燃放次数    Set lastAffected = Nothing    ' 设置错误处理，确保中断时能恢复颜色和屏幕更新    On Error GoTo Cleanup    For shotCount = 1 To totalShots        ' 恢复上一批单元格的原始颜色        If Not lastAffected Is Nothing Then            For Each cell In lastAffected.Cells                rowIndex = cell.Row - rng.Row + 1                colIndex = cell.Column - rng.Column + 1                cell.Interior.color = origColors(rowIndex, colIndex)            Next cell        End If        ' 随机决定本次燃放多少个单元格（5~15 个）        cellsPerShot = Int((15 - 5 + 1) * Rnd + 5)        Set currentAffected = Nothing        For k = 1 To cellsPerShot            ' 随机选取单元格（允许重复，Union 会自动合并）            randRow = Int((cellRows) * Rnd + 1)            randCol = Int((cellCols) * Rnd + 1)            Set cell = rng.Cells(randRow, randCol)            If currentAffected Is Nothing Then                Set currentAffected = cell            Else                Set currentAffected = Union(currentAffected, cell)            End If        Next k        ' 为本次燃放的单元格设置随机暖色        For Each cell In currentAffected.Cells            Select Case Int(3 * Rnd)                Case 0: color = RGB(255, 0, 0)      ' 红                Case 1: color = RGB(255, 165, 0)    ' 橙                Case 2: color = RGB(255, 255, 0)    ' 黄            End Select            cell.Interior.color = color        Next cell        ' 发出蜂鸣声（模拟鞭炮声）        Beep        ' 延时约 0.1 秒（使用 Sleep 使效果更明显）        Sleep 100   ' 100 毫秒        ' 强制刷新屏幕，显示当前变化        Application.ScreenUpdating = True        DoEvents        Application.ScreenUpdating = False        ' 记录本次燃放的单元格，供下一轮恢复        Set lastAffected = currentAffected    Next shotCountCleanup:    ' 恢复所有单元格的原始颜色    If Not lastAffected Is Nothing Then        For Each cell In lastAffected.Cells            rowIndex = cell.Row - rng.Row + 1            colIndex = cell.Column - rng.Column + 1            cell.Interior.color = origColors(rowIndex, colIndex)        Next cell    End If    ' 确保整个区域全部恢复（以防遗漏）    For i = 1 To cellRows        For j = 1 To cellCols            rng.Cells(i, j).Interior.color = origColors(i, j)        Next j    Next i    Application.ScreenUpdating = True    If Err.Number = 0 Then    Else        MsgBox "宏已被中断，颜色已恢复。"    End IfEnd Sub