セルをドットみたいに動かして遊んでみた【Excel VBA】

2015年8月27日2017年5月18日

最近Excelを使うことが多くて、データを分類したり加工したりするマクロを作ったり、久しぶりにVisual Basicでプログラムを書きました。でもずっと方眼紙のようなマス目を見ていると、ファミコンのような昔のゲームを思い出します。

というわけで、今回はエクセルのセルを使って壁に跳ね返るボールのような動きを作ってみました。

動作環境
レイアウト
マクロの作成
マクロをボタンに割り当て
実行してみましょう
おわりに

動作環境

Microsoft Office 365 Soloを使用しています。
WindowsでもMacでも動きますが、Mac版の方はなぜかマクロが実行できないことがありましたのでWindows版の方が安定しているようです。

レイアウト

使うシートは1つだけです。名前は自動で付いている「Sheet1」のままで変更しなくて大丈夫です。

A1のセルからAF22のあたりまで、セルの色を黒く塗って壁を作ります。あとはマクロの実行用に図形を一つ作っておいてください。

マクロの作成

レイアウトの作成が終わったら、マクロを作成します。メニューの「ツール」-「マクロ」-「Visual Basic Editor」でマクロ編集画面を開いて、モジュールを作成します。

※作成方法がわからない場合は、「ツール」-「マクロ」-「新しいマクロを記録」を選んですぐに「ツール」-「マクロ」-「記録終了」を選ぶとサクっと作れます。

簡単に説明しますと、まずcheckCollisionという関数で、ボールが動く先に障害物があるかチェックしています。もし壁やカーソルがあれば移動する方向を反転するようにしています。

Sub dotmove()
    Dim x As Integer
    Dim y As Integer
    Dim nextX As Integer
    Dim nextY As Integer
    Dim moveX As Integer
    Dim moveY As Integer

    'スピード調整用の変数
    Const counter = 2

    '初期座標
    x = 2
    y = 2

    '初期移動方向
    moveX = 1
    moveY = 1

    Do While True
       ' 左右の障害物チェック
        If checkCollision(x + moveX, y) = True Then
            moveX = moveX * -1
        End If
        '上下の障害物チェック
        If checkCollision(x, y + moveY) = True Then
            moveY = moveY * -1
        End If
        '斜め前の障害物チェック
        If checkCollision(x + moveX, y + moveY) = True Then
            moveX = moveX * -1
            moveY = moveY * -1
        End If

        ' 次の表示位置を決定
        nextX = x + moveX
        nextY = y + moveY

        '障害物がなければ描画する
        If checkCollision(nextX, nextY) = False Then
            Worksheets("sheet1").Cells(nextX, nextY).Interior.Color = RGB(0, 0, 255)
            If nextX = x And nextY = y Then
            Else
                Worksheets("sheet1").Cells(x, y).Interior.Color = RGB(255, 255, 255)
            End If
            x = nextX
            y = nextY
        End If

        For I = 0 To counter
            DoEvents
        Next I
    Loop


End Sub

Function checkCollision(x As Integer, y As Integer) As Boolean
    checkCollision = False

    If Worksheets("sheet1").Cells(x, y).Interior.Color <> RGB(0, 0, 0) And Application.Intersect(Range(Worksheets("sheet1").Cells(x, y), Worksheets("sheet1").Cells(x, y)), ActiveCell) Is Nothing Then
    Else
        checkCollision = True
    End If

End Function

Sub dotmove()

Dim x As Integer

Dim y As Integer

Dim nextX As Integer

Dim nextY As Integer

Dim moveX As Integer

Dim moveY As Integer

'スピード調整用の変数

Const counter = 2

'初期座標

x = 2

y = 2

'初期移動方向

moveX = 1

moveY = 1

Do While True

' 左右の障害物チェック

If checkCollision(x + moveX, y) = True Then

moveX = moveX * -1

End If

'上下の障害物チェック

If checkCollision(x, y + moveY) = True Then

moveY = moveY * -1

End If

'斜め前の障害物チェック

If checkCollision(x + moveX, y + moveY) = True Then

moveX = moveX * -1

moveY = moveY * -1

End If

' 次の表示位置を決定

nextX = x + moveX

nextY = y + moveY

'障害物がなければ描画する

If checkCollision(nextX, nextY) = False Then

Worksheets("sheet1").Cells(nextX, nextY).Interior.Color = RGB(0, 0, 255)

If nextX = x And nextY = y Then

Else

Worksheets("sheet1").Cells(x, y).Interior.Color = RGB(255, 255, 255)

End If

x = nextX

y = nextY

End If

For I = 0 To counter

DoEvents

Next I

Loop

End Sub

Function checkCollision(x As Integer, y As Integer) As Boolean

checkCollision = False

If Worksheets("sheet1").Cells(x, y).Interior.Color <> RGB(0, 0, 0) And Application.Intersect(Range(Worksheets("sheet1").Cells(x, y), Worksheets("sheet1").Cells(x, y)), ActiveCell) Is Nothing Then

Else

checkCollision = True

End If

End Function