上級158回のコード

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
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 test4()
    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 = B
    Set p1 = Range("G1")
    Set p2 = Range("G2")
    
    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
        
        Sleep 500
        
        DoEvents
        'y = y + 1
    Loop
    
    'y = y -1
    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 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