上級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
この記事が気に入ったらサポートをしてみませんか?