上級159回のコード

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

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

Sub test5()
    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 rn As Range
    
    y = 0
    
    posi = T
    Set p1 = Range("E2")
    Set p2 = Range("E1")
    
    fg1 = True
    fg2 = True
    
    ReDim list(1 To 15, 1 To 7)
    
    Do While fg1 And fg2
        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
            
            If p1.Row > 1 Then
                p1.Interior.ColorIndex = xlNone
            End If
            
            If p2.Row > 1 Then
                p2.Interior.ColorIndex = xlNone
            End If
            
            Set p1 = p1.Offset(1, 0)
            Set p2 = p1.Offset(y, x)
            
            p1.Interior.color = RGB(255, 0, 0)
            p2.Interior.color = RGB(0, 0, 255)
        
        End If

        Call keyInput

        
        Sleep 500
        
        DoEvents

        
    Loop
    

    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 = RGB(255, 0, 0)
            p1.Offset(y - 1, 0).Interior.ColorIndex = xlNone

        ElseIf fg2 Then

            p2.Offset(y, 0).Interior.color = RGB(0, 0, 255)
            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
        
        '新たに浮いたところを落とす
        
        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 Sub

Sub test6()
    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 count As Long
    
    
    Dim rn As Range
    
    

    
    y = 0
    
    posi = T
    Set p1 = Range("E2")
    Set p2 = Range("E1")
    
    fg1 = True
    fg2 = True
    
    ReDim list(1 To 15, 1 To 7)
    
    Do While fg1 And fg2
        If count Mod 5 = 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
                
                If p1.Row > 1 Then
                    p1.Interior.ColorIndex = xlNone
                End If
                
                If p2.Row > 1 Then
                    p2.Interior.ColorIndex = xlNone
                End If
                
                Set p1 = p1.Offset(1, 0)
                Set p2 = p1.Offset(y, x)
                
                p1.Interior.color = RGB(255, 0, 0)
                p2.Interior.color = RGB(0, 0, 255)
            
            End If
        
        End If

        Call keyInput

        
        Sleep 100
        count = count + 1
        DoEvents

        
    Loop
    

    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 = RGB(255, 0, 0)
            p1.Offset(y - 1, 0).Interior.ColorIndex = xlNone

        ElseIf fg2 Then

            p2.Offset(y, 0).Interior.color = RGB(0, 0, 255)
            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
        
        '新たに浮いたところを落とす
        
        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 Sub



Sub 回転()

    Select Case posi
        Case T
            p2.Interior.ColorIndex = xlNone
            Set p2 = p1.Offset(0, 1)
            p2.Interior.color = RGB(0, 0, 255)
            posi = R
        Case R
            p2.Interior.ColorIndex = xlNone
            Set p2 = p1.Offset(1, 0)
            p2.Interior.color = RGB(0, 0, 255)
            posi = B
        Case B
            p2.Interior.ColorIndex = xlNone
            Set p2 = p1.Offset(0, -1)
            p2.Interior.color = RGB(0, 0, 255)
            posi = L
        Case L
            p2.Interior.ColorIndex = xlNone
            Set p2 = p1.Offset(-1, 0)
            p2.Interior.color = RGB(0, 0, 255)
            posi = T
    End Select
    


End Sub

Sub keyInput()
    
    If GetAsyncKeyState(vbKeyA) Then
    
        Call 回転
        
    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