上級34回のコード

 #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
Public flag As Boolean
Private xy(0 To 1)
Private tekis() As Integer
Sub StageRead()
   Dim gyo As Integer
   Dim retu As Integer
   Dim menID As Integer
   Dim i As Integer
   
   Dim masus() As String
   Dim tekis() As String
   Dim tekiData() As String
   Dim mys() As String
   
   Dim teki As Variant
   
   Dim r As Range
   
   Dim ws1 As Worksheet
   Dim ws2 As Worksheet
   Dim ws3 As Worksheet
   
   Set ws1 = ThisWorkbook.Worksheets("game")
   Set ws2 = ThisWorkbook.Worksheets("設定")
   Set ws3 = ThisWorkbook.Worksheets("面データ")
   
   ws2.Range("B8:K10") = ""
   
   menID = 1
   
   masus = Split(ws3.Cells(menID + 1, 4), ",")
   
   
   i = 0
   
   For gyo = 1 To 30
       For retu = 1 To 66
           Set r = ws1.Range(ws1.Cells(gyo, retu + 4), ws1.Cells(gyo, retu + 4))
           
           Select Case Val(masus(i))
               Case 1
                   r.Interior.Color = RGB(0, 0, 0)
               Case 2
                   r.Interior.Color = RGB(255, 0, 0)
               Case Else
                   r.Interior.ColorIndex = xlNone
           End Select
           i = i + 1
       Next retu
   Next gyo
   
   tekis = Split(ws3.Cells(menID + 1, 3), ":")
   
   i = 0
   
   For Each teki In tekis
   
       tekiData = Split(teki, ",")
       ws2.Cells(8, 2 + i) = tekiData(0)
       ws2.Cells(9, 2 + i) = tekiData(1)
       ws2.Cells(10, 2 + i) = tekiData(2)
       
       i = i + 1
   Next
   
   mys = Split(ws3.Cells(menID + 1, 2), ",")
   ws2.Cells(13, 2) = mys(0)
   ws2.Cells(14, 2) = mys(1)
   
End Sub
Sub StageCapture()
   Dim gyo As Integer
   Dim retu As Integer
   Dim masu As Integer
   
   Dim men As String
   Dim my As String
   Dim teki As String
   Dim tekis As String
   
   Dim r As Range
   
   Dim ws1 As Worksheet
   Dim ws2 As Worksheet
   Dim ws3 As Worksheet
   
   Set ws1 = ThisWorkbook.Worksheets("面作成用")
   Set ws2 = ThisWorkbook.Worksheets("設定")
   Set ws3 = ThisWorkbook.Worksheets("面データ")
   
   For gyo = 1 To 30
       For retu = 1 To 66
           Set r = ws1.Range(ws1.Cells(gyo, retu + 4), ws1.Cells(gyo, retu + 4))
           
           Select Case r.Interior.Color
               Case RGB(0, 0, 0)
                   masu = 1
               Case RGB(255, 0, 0)
                   masu = 2
               Case Else
                   masu = 0
           End Select
           
           men = men & masu & ","
           
           If r.Value = "◎" Then
               my = retu + 4 & "," & gyo
               
           ElseIf r.Value <> "" Then
           
               For i = 0 To 3
                   If r.Value = ws2.Cells(i + 2, 2).Value Then
                       teki = i & "," & retu + 4 & "," & gyo
                       tekis = tekis & teki & ":"
                   End If
               Next i
           End If
           
           
       Next retu
   Next gyo
   
   men = Left(men, Len(men) - 1)
   tekis = Left(tekis, Len(tekis) - 1)
   
   gyo = 2
   
   Do While ws3.Cells(gyo, 2) <> ""
       gyo = gyo + 1
   Loop
   
   ws3.Cells(gyo, 2) = my
   ws3.Cells(gyo, 3) = tekis
   ws3.Cells(gyo, 4) = men
   
End Sub
Sub keyInput()
   
   If GetAsyncKeyState(vbKeyLeft) Then
   
       Call my_move(-1, 0)
       
   ElseIf GetAsyncKeyState(vbKeyRight) Then
   
       Call my_move(1, 0)
       
   ElseIf GetAsyncKeyState(vbKeyUp) Then
   
       Call my_move(0, -1)
       
   ElseIf GetAsyncKeyState(vbKeyDown) Then
   
       Call my_move(0, 1)
       
   End If
End Sub

Sub my_move(x, y)
   
   Dim r As Range
   
   Set r = Range(Cells(xy(1) + y, xy(0) + x), Cells(xy(1) + y, xy(0) + x))
   If r.Interior.Color = RGB(255, 0, 0) Then
       Cells(xy(1), xy(0)) = ""
       xy(0) = xy(0) + x
       xy(1) = xy(1) + y
       MsgBox "Goooooooooool"
       Worksheets("game").CommandButton1.caption = "スタート"
       flag = False
       
   ElseIf r.Interior.Color <> RGB(0, 0, 0) Then
       Cells(xy(1), xy(0)) = ""
       xy(0) = xy(0) + x
       xy(1) = xy(1) + y
       
   End If
End Sub
Sub tekiMove(c As Long, n As Integer)
   Dim s As Integer
   
   Dim r As Range
   Dim x As Integer
   Dim y As Integer
   Dim muki As Integer
   
   Select Case tekis(0, n)
       Case 0:
           s = 3
       Case 1:
           s = 4
   
   End Select
   
   If c Mod s = 0 Then
   
       Select Case tekis(0, n)
           Case 0:
               muki = Int(4 * Rnd + 1)
               
               Select Case muki
                   Case 1:
                       x = -1
                       y = 0
                   Case 2:
                       x = 1
                       y = 0
                   Case 3:
                       x = 0
                       y = -1
                   Case Else:
                       x = 0
                       y = 1
               End Select
           Case 1:
           
               If c Mod s * 2 = 0 Then
               
                   If xy(0) - tekis(1, n) < 0 Then
                       x = -1
                   Else
                       x = 1
                   End If
               Else
                   If xy(1) - tekis(2, n) < 0 Then
                       y = -1
                   Else
                       y = 1
                   End If
               End If
       
       End Select
       
       
       
       Set r = Range(Cells(tekis(2, n) + y, tekis(1, n) + x), Cells(tekis(2, n) + y, tekis(1, n) + x))
   
       If r.Interior.Color <> RGB(0, 0, 0) Then
           Cells(tekis(2, n), tekis(1, n)) = ""
           tekis(1, n) = tekis(1, n) + x
           tekis(2, n) = tekis(2, n) + y
       End If
   End If
End Sub
Sub game()
   Call StageRead
   Dim i As Integer
   Dim j As Integer
   
   Dim c As Long
   
   
   Dim tekiNum As Integer
   Dim tekiMoji(0 To 3) As String
   
   Dim ws1 As Worksheet
   Dim ws2 As Worksheet
   
   Set ws1 = ThisWorkbook.Worksheets("game")
   Set ws2 = ThisWorkbook.Worksheets("設定")
   
   Randomize
   
   For i = 0 To 3
       tekiMoji(i) = ws2.Cells(2 + i, 2)
   Next i
   
   teki_num = 0
   
   Do While ws2.Cells(8, tekiNum + 2) <> ""
       tekiNum = tekiNum + 1
   Loop
   
   ReDim tekis(2, tekiNum - 1)
   
   For j = 0 To tekiNum - 1
       For i = 0 To 2
           tekis(i, j) = ws2.Cells(8 + i, 2 + j)
       Next i
       
   Next j
   
   ws1.Range("L2").Select
   
   
   xy(0) = ws2.Cells(13, 2)
   xy(1) = ws2.Cells(14, 2)
   
   Do While flag
       
       Cells(xy(1), xy(0)) = "◎"
 
       For i = 0 To tekiNum - 1
           Cells(tekis(2, i), tekis(1, i)) = tekiMoji(tekis(0, i))
       Next i
       
       Sleep 50
       DoEvents
       
       Call keyInput
       
       For i = 0 To tekiNum - 1
           Call tekiMove(c, i)
       Next i
       
       i = 0
       Do While i < tekiNum And flag
           If xy(0) = tekis(1, i) And xy(1) = tekis(2, i) Then
               flag = False
               Worksheets("game").CommandButton1.caption = "スタート"
               MsgBox "Game Over"
               
           End If
           i = i + 1
       Loop
       
       Range("L2").Select
       
       c = c + 1
       
   Loop
   
   Range("A1:BA30") = ""
End Sub

Private Sub CommandButton1_Click()
   
   If flag Then 'ストップ処理
       flag = False
       CommandButton1.caption = "スタート"
       
   Else         'スタート処理
       flag = True
       CommandButton1.caption = "ストップ"
       Call game
       
   End If
End Sub