Excel VBA骰子归位异常：Do While循环无法终止导致持续左移

编写的Excel VBA脚本可实现骰子屏幕滚动，需求是骰子滚动后移回屏幕中心（Left=500位置）。但执行时出现异常：骰子滚动到右侧后，仅Group 38开始左移，且不会在Left=500处停止，一直移到屏幕左侧。

问题根源 #

循环判断条件Do While wsCraps.Shapes.Range(Array("Group 39")).Left >= 500监测的是Group 39的位置，但循环体内仅对Group 38执行左移操作，Group 39的位置始终不变，导致判断条件永远为True，循环无法终止。

修复后的完整代码 #

Sub Roll_Dice()
Dim leftDieRotation As Single, rightDieRotation As Single, leftDieMovement As Single, rightDieMovement As Single
Dim wsCraps As Worksheet
Set wsCraps = Sheets("Craps")

' 初始化骰子位置
With wsCraps.Shapes.Range(Array("Group 38"))
   .Left = 500
   .Top = 80
End With
With wsCraps.Shapes.Range(Array("Group 39"))
    .Left = 500
    .Top = 180
End With

' 骰子滚动动画
For x = 1 To 50
   Randomize
   leftDieRotation = Int(10 + Rnd * 25)
   leftDieMovement = Int(2 + Rnd * 25)
   rightDieRotation = Int(10 + Rnd * 25)
   rightDieMovement = Int(2 + Rnd * 25)
   
    With wsCraps.Shapes.Range(Array("Group 38"))
        .IncrementRotation leftDieRotation
        .IncrementLeft leftDieMovement
    End With
   With wsCraps.Shapes.Range(Array("Group 39"))
        .IncrementRotation rightDieRotation
        .IncrementLeft rightDieMovement
    End With
   
    Sheets("dice").Range("a1") = Int((6 - 1 + 1) * Rnd + 1)
    Sheets("dice").Range("e1") = Int((6 - 1 + 1) * Rnd + 1)
    DoEvents
Next x

' 修复：同步移动两个骰子回中心
Do While wsCraps.Shapes.Range(Array("Group 39")).Left >= 500
    ' 同时移动Group 38和Group 39
    With wsCraps.Shapes.Range(Array("Group 38"))
        .IncrementLeft -5
    End With
    With wsCraps.Shapes.Range(Array("Group 39"))
        .IncrementLeft -5
    End With
    DoEvents
Loop

' 可选优化：直接设置Left值（更高效，避免循环过度移动）
' wsCraps.Shapes.Range(Array("Group 38")).Left = 500
' wsCraps.Shapes.Range(Array("Group 39")).Left = 500
End Sub

修改说明 #

• 核心修复：在循环体内同步对Group 38和Group 39执行.IncrementLeft -5操作，确保两个骰子的Left值同时减小，当Group 39的Left降到500以下时，循环正常终止
• 可选优化：如果不需要回位动画效果，直接设置.Left = 500比循环增量移动更高效，还能避免因增量导致的位置偏差

内容的提问来源于stack exchange，提问作者Bill Flippen