上級163回のコード

Option Explicit
 #If  VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else 
    Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long) #End  If

Private Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Dim posi As Integer
Dim p1 As Range
Dim p2 As Range
Dim list() As Long

Dim count As Long
Dim bCount As Long
Dim bKey As Long

Const T As Integer = 1
Const R As Integer = 2
Const B As Integer = 3
Const L As Integer = 4

Dim p1color As Long
Dim p2color As Long

 '追加
Public fg As Boolean

Sub game()
    
    '色数
    Dim num As Integer
    
    Dim colors(4) As Long
    
    Range("B2:H15").Clear
    
    num = 4
    
    colors(0) = RGB(255, 0, 0)
    colors(1) = RGB(0, 0, 255)
    colors(2) = RGB(255, 220, 0)
    colors(3) = RGB(0, 200, 0)
    colors(4) = RGB(230, 0, 240)

    Randomize
    
    p1color = colors(Int(num * Rnd))
    p2color = colors(Int(num * Rnd))
    
    Range("K4").Interior.color = colors(Int(num * Rnd))
    Range("K5").Interior.color = colors(Int(num * Rnd))
    
    Call test7
    
    Do While fg '変更
        If Range("E2").Interior.ColorIndex = xlNone Then
        
            p1color = Range("K5").Interior.color
            p2color = Range("K4").Interior.color
        
            Range("K4").Interior.color = colors(Int(num * Rnd))
            Range("K5").Interior.color = colors(Int(num * Rnd))
            
            Call test7
        Else
            fg = False
            MsgBox "ばたんきゅ～"
        End If
    Loop
End Sub


Sub test7()
    Dim fg1 As Boolean
    Dim fg2 As Boolean
    
    Dim x As Integer
    Dim y As Integer
    Dim c As Collection
    Dim color As Long
    
    
    Dim wait As Integer
    
    
    
    Dim rn As Range
    

    y = 0
    
    posi = T
    Set p1 = Range("E2")
    Set p2 = Range("E1")
    

    count = 1
    p1.Interior.color = p1color
    p2.Interior.color = p2color

    wait = 10
    
    fg1 = True
    fg2 = True

    ReDim list(1 To 15, 1 To 7)
    
    Do While fg1 And fg2 And fg
    
        If bKey = vbKeyDown Then
            wait = 1
        Else
            wait = 10
        End If
        
        If count Mod wait = 0 Then
            Select Case posi
                Case T
                    fg1 = p1.Offset(1, 0).Interior.ColorIndex = xlNone
                    y = -1
                    x = 0
                    
                Case R
                    fg1 = p1.Offset(1, 0).Interior.ColorIndex = xlNone
                    fg2 = p2.Offset(1, 0).Interior.ColorIndex = xlNone
                    
                    y = 0
                    x = 1
                    
                Case B
                    fg2 = p2.Offset(1, 0).Interior.ColorIndex = xlNone
                    
                    y = 1
                    x = 0
                    
                Case L
                    fg1 = p1.Offset(1, 0).Interior.ColorIndex = xlNone
                    fg2 = p2.Offset(1, 0).Interior.ColorIndex = xlNone
                    
                    y = 0
                    x = -1
            End Select
            
                   
            If fg1 And fg2 Then
                

                p1.Interior.ColorIndex = xlNone

                p2.Interior.ColorIndex = xlNone

                
                Set p1 = p1.Offset(1, 0)
                Set p2 = p1.Offset(y, x)
                
                p1.Interior.color = p1color
                p2.Interior.color = p2color
            
            End If
        
        End If

        Call keyInput

        
        Sleep 100
        count = count + 1
        DoEvents

        
    Loop
    

    If fg Then
        y = 1
        
        '浮いてる方を落とす
        Do While fg1 Or fg2
    
            fg1 = p1.Offset(y, 0).Interior.ColorIndex = xlNone
            fg2 = p2.Offset(y, 0).Interior.ColorIndex = xlNone
    
            If fg1 Then
    
                p1.Offset(y, 0).Interior.color = p1color
                p1.Offset(y - 1, 0).Interior.ColorIndex = xlNone
    
            ElseIf fg2 Then
    
                p2.Offset(y, 0).Interior.color = p2color
                p2.Offset(y - 1, 0).Interior.ColorIndex = xlNone
    
            End If
    
            Sleep 250
    
            DoEvents
            y = y + 1
        Loop
        
    
        
        fg1 = True
        Do While fg1
            fg1 = False
        
            
            
            '4個以上つながった所を消す
            ReDim list(1 To 15, 1 To 7)
    
            For y = 1 To 15
                For x = 1 To 7
                    list(y, x) = 1
                    If Range("a1").Offset(y - 1, x).Interior.ColorIndex <> xlNone Then
                        
                        color = Range("a1").Offset(y - 1, x).Interior.color
                        
                        Set c = New Collection
                        c.Add Range("a1").Offset(y - 1, x)
                        Check c, y, x, color
                        
                        If c.count >= 4 Then
                            fg1 = True
                            For Each rn In c
                                rn.Interior.ColorIndex = xlNone
                            Next
                        End If
                        
                    End If
                Next x
            Next y
            
            '新たaに浮いたところを落とす
            
            fg2 = True
            Do While fg2
                fg2 = False
                For y = 14 To 1 Step -1
                    For x = 1 To 7
                        If Range("a1").Offset(y - 1, x).Interior.ColorIndex <> xlNone Then
                            If Range("a1").Offset(y, x).Interior.ColorIndex = xlNone Then
                                color = Range("a1").Offset(y - 1, x).Interior.color
                                Range("a1").Offset(y, x).Interior.color = color
                                Range("a1").Offset(y - 1, x).Interior.ColorIndex = xlNone
                                fg2 = True
                            End If
                        End If
                    Next x
            
                Next y
                
                DoEvents
                Sleep 250
                
            Loop
            
            
        Loop
    
    End If
End Sub




Sub 回転(bKey As Long)

    Select Case posi
        Case T
            '右が空白
            If p1.Offset(0, 1).Interior.ColorIndex = xlNone Then
                p2.Interior.ColorIndex = xlNone
                Set p2 = p1.Offset(0, 1)
                p2.Interior.color = p2color
                posi = R
                bKey = vbKeyA
            '左は空白
            
            ElseIf p1.Offset(0, -1).Interior.ColorIndex = xlNone Then
                p2.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(0, -1)
                Set p2 = p1.Offset(0, 1)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
                posi = R
                bKey = vbKeyA
                
            '両方空いていないが前回入力が回転の場合
            ElseIf bKey = vbKeyA Then
            
                If p1.Offset(1, 0).Interior.ColorIndex = xlNone Then
                    Set p1 = p1.Offset(-1, 0)
                    Set p2 = p1.Offset(1, 0)
                    p1.Interior.color = p1color
                    p2.Interior.color = p2color
                    posi = B
                Else
                    p2.Interior.ColorIndex = xlNone
                    Set p1 = p1.Offset(-1, 0)
                    Set p2 = p1.Offset(1, 0)
                    p1.Interior.color = p1color
                    p2.Interior.color = p2color
                    posi = B
                End If
            
                bKey = 0
                
            Else
                bKey = vbKeyA
            End If

        Case R
            If p1.Offset(1, 0).Interior.ColorIndex = xlNone Then
                p2.Interior.ColorIndex = xlNone
                Set p2 = p1.Offset(1, 0)
                p2.Interior.color = p2color
                posi = B
            Else
                p2.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(-1, 0)
                Set p2 = p1.Offset(1, 0)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
                posi = B
            End If
            
            bKey = vbKeyA
        Case B
        
            '左が空白
            If p1.Offset(0, -1).Interior.ColorIndex = xlNone Then
                p2.Interior.ColorIndex = xlNone
                Set p2 = p1.Offset(0, -1)
                p2.Interior.color = p2color
                posi = L
                
                bKey = vbKeyA
            '右は空白
            ElseIf p1.Offset(0, 1).Interior.ColorIndex = xlNone Then
                p2.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(0, 1)
                Set p2 = p1.Offset(0, -1)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
                posi = R
                
                bKey = vbKeyA
            '両方空いていないが前回入力が回転の場合
            ElseIf bKey = vbKeyA Then
            
                
                Set p1 = p1.Offset(1, 0)
                Set p2 = p1.Offset(-1, 0)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
                posi = T
            
                bKey = 0
            Else
                bKey = vbKeyA
            
            End If
        
        
        Case L
            
            p2.Interior.ColorIndex = xlNone
            Set p2 = p1.Offset(-1, 0)
            p2.Interior.color = p2color
            posi = T
            
            bKey = vbKeyA
    End Select
    


End Sub

Sub 移動(x As Integer)

    Select Case posi
        Case T
            If p1.Offset(0, x).Interior.ColorIndex = xlNone Then
                p1.Interior.ColorIndex = xlNone
                p2.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(0, x)
                Set p2 = p2.Offset(0, x)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
            End If
        Case R
            
            If x = 1 And p1.Offset(0, 2).Interior.ColorIndex = xlNone Then
                p1.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(0, x)
                Set p2 = p2.Offset(0, x)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
                
            ElseIf x = -1 And p1.Offset(0, -1).Interior.ColorIndex = xlNone Then
                p2.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(0, x)
                Set p2 = p2.Offset(0, x)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
            End If
        
        
        Case B
            If p2.Offset(0, x).Interior.ColorIndex = xlNone Then
                p1.Interior.ColorIndex = xlNone
                p2.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(0, x)
                Set p2 = p2.Offset(0, x)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
            End If
            
        Case L
            If x = 1 And p1.Offset(0, 1).Interior.ColorIndex = xlNone Then
                p2.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(0, x)
                Set p2 = p2.Offset(0, x)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
                
            ElseIf x = -1 And p1.Offset(0, -2).Interior.ColorIndex = xlNone Then
                p1.Interior.ColorIndex = xlNone
                Set p1 = p1.Offset(0, x)
                Set p2 = p2.Offset(0, x)
                p1.Interior.color = p1color
                p2.Interior.color = p2color
            End If
    End Select

End Sub


Sub keyInput()
    If bKey <> vbKeyA Then
        bKey = 0
    ElseIf count - bCount > 6 Then
        bKey = 0
        
    End If
    
    If GetAsyncKeyState(vbKeyA) Then
        bCount = count
        Call 回転(bKey)
        bKey = vbKeyA
    ElseIf GetAsyncKeyState(vbKeyRight) Then
        bCount = count
        Call 移動(1)
        bKey = vbKeyRight
    ElseIf GetAsyncKeyState(vbKeyLeft) Then
        bCount = count
        Call 移動(-1)
        bKey = vbKeyLeft
    ElseIf GetAsyncKeyState(vbKeyDown) Then
        bCount = count
        bKey = vbKeyDown

    End If
End Sub

Sub Check(c As Collection, y As Integer, x As Integer, color)

    If y < 15 Then
        If list(y + 1, x) = 0 Then
            If Range("a1").Offset(y, x).Interior.color = color Then
                list(y + 1, x) = 1
                c.Add Range("a1").Offset(y, x)
                Check c, y + 1, x, color
            End If
        End If
    End If
    
    If x > 1 Then
        If list(y, x - 1) = 0 Then
            If Range("a1").Offset(y - 1, x - 1).Interior.color = color Then
                list(y, x - 1) = 1
                c.Add Range("a1").Offset(y - 1, x - 1)
                Check c, y, x - 1, color
            End If
        End If
    End If
    
    If x < 7 Then
        If list(y, x + 1) = 0 Then
            If Range("a1").Offset(y - 1, x + 1).Interior.color = color Then
                list(y, x + 1) = 1
                c.Add Range("a1").Offset(y - 1, x + 1)
                Check c, y, x + 1, color
            End If
        End If
    End If

End Sub

Option Explicit

Private Sub CommandButton1_Click()
    If Not fg Then
        CommandButton1.Caption = "終了"
        DoEvents
        
        fg = True
        Call game
        
    Else
        CommandButton1.Caption = "開始"
        DoEvents
        
        fg = False
        
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If fg Then
        Range("a1").Select
        Range("a1") = ""
    End If
End Sub