上級156回のコード

 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 test2()
    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("D1")
    Set p2 = Range("E1")
    
    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
    
    '4個以上つながった所を消す
    
    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
                    For Each rn In c
                        rn.Interior.ColorIndex = xlNone
                    Next
                End If
                
            End If
        Next x
    Next y
    
    ReDim list(1 To 15, 1 To 7)
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