移动有色单元格

Question

是否可以循环一个单元格（有颜色可以说是红色）来回移动，让我们说A1到I1？

我试过简单地录制它，但它移动得太快而宏运行时我不能做任何其他事情，比如写...

Answer 1

以下是如何移动“汽车”的基本演示，该按钮与StartGame相关联。文件可以下载Here

将此代码粘贴到模块中

Dim i As Long, j As Long, k As Long
Dim ws As Worksheet
Dim r As Range

Sub StartGame()
    Set ws = ThisWorkbook.Sheets("Sheet1")
    i = 1: j = 1: k = 1

    MoveCar1
End Sub

Sub MoveCar1()
    With ws
        Set r = .Cells(6, i)

        r.Cut
        r.Offset(, 2).Insert Shift:=xlToRight
        i = i + 1
    End With

    Wait 1

    MoveCar2
End Sub

Sub MoveCar2()
    With ws
        Set r = .Cells(6, i)

        r.Cut
        r.Offset(, 2).Insert Shift:=xlToRight
        i = i + 1

        Set r = .Cells(8, j)

        r.Cut
        r.Offset(, 2).Insert Shift:=xlToRight
        j = j + 1
    End With

    Wait 1

    MoveCar3
End Sub

Sub MoveCar3()
    With ws
        Set r = .Cells(6, i)
        r.Cut
        r.Offset(, 2).Insert Shift:=xlToRight
        i = i + 1

        Set r = .Cells(8, j)
        r.Cut
        r.Offset(, 2).Insert Shift:=xlToRight
        j = j + 1

        Set r = .Cells(10, k)
        r.Cut
        r.Offset(, 2).Insert Shift:=xlToRight
        k = k + 1
    End With

    Wait 1

    MoveAllCars
End Sub

Sub MoveAllCars()
    For l = 1 To 8
        With ws
            If i < 9 Then
                Set r = .Cells(6, i)
                r.Cut
                r.Offset(, 2).Insert Shift:=xlToRight
                i = i + 1
            End If

            If j < 9 Then
                Set r = .Cells(8, j)
                r.Cut
                r.Offset(, 2).Insert Shift:=xlToRight
                j = j + 1
            End If

            If k < 9 Then
                Set r = .Cells(10, k)
                r.Cut
                r.Offset(, 2).Insert Shift:=xlToRight
                k = k + 1
            End If

            Wait 1

            If i > 8 And j > 8 And k > 8 Then Exit For
        End With
    Next l
End Sub

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

<强>截图

Answer 2

考虑一下：

Sub MyGame()
   Dim A As Range, I As Range, T As Date
   Dim T30 As Date
   Set A = Range("A1")
   Set I = Range("I1")
   A.Interior.ColorIndex = 3
   T = Now
   T30 = T + TimeSerial(0, 0, 5)
   While Now < T30
      DoEvents
      If A.Interior.ColorIndex = 3 Then
         A.Interior.ColorIndex = xlNone
         I.Interior.ColorIndex = 3
      Else
         A.Interior.ColorIndex = 3
         I.Interior.ColorIndex = xlNone
      End If
   Wend
End Sub

它会将单元格 A1 设置为红色，然后在 A1 和 I1 之间来回移动该颜色约10秒钟。