上級157回のコード

 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 list() As Long

Sub test3()
    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
    
    
    Dim p1 As Range
    Dim p2 As Range
    
    y = 0
    
    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
        
        'p1が下
        If p1.Row > p2.Row Then
        
            fg1 = p1.Offset(y, 0).Interior.ColorIndex = xlNone
            If fg1 Then
            
                p1.Offset(y, 0).Interior.color = RGB(255, 0, 0)
    
                p2.Offset(y, 0).Interior.color = RGB(0, 0, 255)
                
                If y > 0 Then
                    p2.Offset(y - 1, 0).Interior.ColorIndex = xlNone
                End If
                
            End If
            
        'p2が下
        ElseIf p1.Row < p2.Row Then
        
            fg2 = p2.Offset(y, 0).Interior.ColorIndex = xlNone
            If fg2 Then
            
                p1.Offset(y, 0).Interior.color = RGB(255, 0, 0)
    
                p2.Offset(y, 0).Interior.color = RGB(0, 0, 255)
                
                If y > 0 Then
                    p1.Offset(y - 1, 0).Interior.ColorIndex = xlNone
                End If
                
            End If
        '横
        Else
        
            fg1 = p1.Offset(y, 0).Interior.ColorIndex = xlNone
            fg2 = p2.Offset(y, 0).Interior.ColorIndex = xlNone
            
            If fg1 And fg2 Then
            
                p1.Offset(y, 0).Interior.color = RGB(255, 0, 0)

                p2.Offset(y, 0).Interior.color = RGB(0, 0, 255)
                If y > 0 Then
                    p1.Offset(y - 1, 0).Interior.ColorIndex = xlNone
                    p2.Offset(y - 1, 0).Interior.ColorIndex = xlNone
                End If
                
            End If
        End If
        

        
        Sleep 500
        
        DoEvents
        y = y + 1
        
    Loop
    
    y = 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