【コピペOK】ついに完成！エクセルマクロでブロック崩しゲームを作ろう！

'変数の宣言
Dim vx As Single    'ボールのx方向の変化量
Dim vy As Single    'ボールのy方向の変化量
Dim x As Single     'ボールのxの現在位置
Dim y As Single     'ボールのyの現在位置
Dim b_px(100) As Single  'ブロックの現在位置x
Dim b_py(100) As Single  'ブロックの現在位置y
Dim r_px As Single 'ラケットの現在位置x
Dim r_py As Single 'ラケットの現在位置y


Sub ブロック崩し()

'変数の値が入っているセルを指定する
vx = Cells(6, 2)
vy = Cells(6, 3)
x = Cells(2, 2) 'X座標の初期位置
y = Cells(2, 3) 'Y座標の初期位置

'ボールの座標を動かす処理

Do
    Calculate
    
    'xとyの現在位置に変化量を足す
    x = x + vx
    y = y + vy
    
    'xとyの現在位置を置き換える
    Cells(4, 2) = x
    Cells(4, 3) = y
    
    '壁反射の処理を呼び出す
    Call 壁反射
    Call ブロック消し
    Call ラケット_ボール判定
    
    'ゲームクリア判定処理
    If IsGameClear() Then
        Cells(1, 6) = "ゲームクリア"
        Exit Sub ' マクロの実行を終了
    End If
        
    'ゲームオーバー判定処理
    If IsGameOver() Then
        Cells(1, 6) = "ゲームオーバー"
        Exit Sub ' マクロの実行を終了
    End If
    
    '途中で江別のマクロが実行されたらLoop処理を止める
    DoEvents
Loop

End Sub
Private Sub 壁反射()
'ボールの現在位置xの値を取得
Select Case Cells(4, 2).Value
'xの値が9.5以上もしくは0.5以下だったらx方向の変化量に-1をかける
Case Is >= 9.5
    vx = -1 * vx
Case Is <= 0.5
    vx = -1 * vx
End Select

'ボールの現在位置yの値を取得
Select Case Cells(4, 3).Value
'yの値が9.5以上もしくは0.5以下だったらx方向の変化量に-1をかける
Case Is >= 9.5
    vy = -1 * vy
Case Is <= 0.5
    vy = 0
End Select
End Sub
Private Sub ブロック消し()
'ブロック18個に対して位置を確認→ボールに当たったらブロックを消す
For n = 0 To 17
    b_px(n) = Cells(8 + n, 2)
    b_py(n) = Cells(8 + n, 3)
If y > b_py(n) - 0.45 And y < b_py(n) + 0.45 Then
If x < b_px(n) + 0.45 And x > b_px(n) - 0.45 Then
vy = -1 * vy
Cells(8 + n, 3) = ""
Else
End If
Else
End If

If x > b_px(n) - 0.45 And x < b_px(n) + 0.45 Then
If y < b_py(n) + 0.45 And y > b_py(n) - 0.45 Then
vx = -1 * vx
Cells(8 + n, 3) = ""
Else
End If
Else
End If
Next n
End Sub
Sub ラケット右移動()
r_px = Cells(27, 2)
'ラケットの現在位置が9未満だったら右に0.3動かす
If r_px < 9 Then
r_px = r_px + 0.3
Cells(27, 2) = r_px
End If
End Sub
Sub ラケット左移動()
r_px = Cells(27, 2)
'ラケットの現在位置が1より大きければ右に0.3動かす
If r_px > 1 Then
r_px = r_px - 0.3
Cells(27, 2) = r_px
End If
End Sub
Private Sub ラケット_ボール判定()
r_px = Cells(27, 2) 'ラケットの現在位置x
r_py = Cells(27, 3) 'ラケットの現在位置y

'ラケットの現在位置ｙとボールの現在位置yを比較
'ラケットよりボールが下に来た場合、次の処理へ
If r_py > y Then

'ラケットの現在位置xとボールの現在位置xを比較
'ラケットの現在位置±0.8の範囲にボールの現在位置xが入っている場合次の処理へ

If r_px + 0.8 > x And r_px - 0.8 < x Then
'ボールが進む方向を変える
vy = -1 * vy
End If
End If
End Sub
Private Function IsGameClear() As Boolean
    Dim row As Integer
    
    ' ブロックの範囲において値が存在するセルがあるかチェック
    For row = 8 To 25
        If Not IsEmpty(Range("C" & row)) Then
            IsGameClear = False ' 値が存在するセルが見つかった場合はゲームクリアではない
            Exit Function
        End If
    Next row
    
    IsGameClear = True ' 全てのセルが空白の場合はゲームクリア
End Function
Private Function IsGameOver() As Boolean
    Dim go As Single
    
    go = Cells(4, 3)
    'ボールの位置yが１以上ならゲーム継続
    If go >= 0.8 Then
        IsGameOver = False
        Exit Function
    End If
    
    'ボールの位置yが１未満になったらゲームオーバー
    IsGameOver = True
    
End Function
Sub リセット()
    'ボールの初期位置x,yを変数に入れる
    Dim f_bpx As Single
    Dim f_bpy As Single
    
    f_bpx = Cells(2, 2)
    f_bpy = Cells(2, 3)
    
    'ボールの現在位置にボールの初期位置の値を入れる
    
    Cells(4, 2) = f_bpx
    Cells(4, 3) = f_bpy
    
    'ブロック位置yに9or8を入力する
    
    Dim row_9 As Integer
    Dim row_8 As Integer
    
    For row_9 = 8 To 16
        Cells(row_9, 3) = 9
    Next row_9
    
    For row_8 = 17 To 25
        Cells(row_8, 3) = 8
    Next row_8
    
    'ゲームクリアorゲームオーバーの表示をクリアする
    Cells(1, 6) = ""
    
End Sub