マラソンゲーム

Excelを使った参加型ゲームの第２弾です。

実際に動かしてみようと思う方は標準モジュールに以下のプログラムをコピペしてください。

ＶＢＡって使ったことが無いという方はこちらを参考にしてみてください。

http://www.officepro.jp/excelvba/ini/index1.html
http://www.officepro.jp/excelvba/ini/index2.html

手順は、

①　画面作成コード（MakeSheet）を実行して画面を作る
②　できた画面にプレイヤーデータを追加する
　　サンプルプレイヤーデータを表ごと選択してコピーし、Excelの名前の下に形式を選択して貼り付けからテキストを選んで貼り付けると簡単です。
③　プログラムコード（GameStart）を実行してゲームスタート
　　プログラムコードを実行するときは、画面にスタートボタンをつけたり、ショートカットを登録するといいです。

画面作成コード

Sub MakeSheet()
    With ActiveSheet.Cells
        .RowHeight = 22.5
        .ColumnWidth = 3.13
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    With ActiveSheet.Range("A1:O20")
        .Interior.ColorIndex = 2
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
    End With
    With ActiveSheet.Range("F6:J15")
        .Interior.ColorIndex = 35
        .Font.ColorIndex = 46
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
    End With
    With ActiveSheet.Range("A10:E10")
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeBottom).ColorIndex = 3
    End With
    With ActiveSheet
        .Range("A1:Q21").Font.Size = 20
        .Columns("R:U").ColumnWidth = 6.88
        .Columns("V:Z").ColumnWidth = 4.6
        .Range("R1").Value = "名前"
        .Range("S1").Value = "スピード"
        .Range("T1").Value = "コーナー"
        .Range("U1").Value = "スタミナ"
        .Range("V1").Value = "１周目"
        .Range("W1").Value = "２周目"
        .Range("X1").Value = "３週目"
        .Range("Y1").Value = "４週目"
        .Range("Z1").Value = "順位"
    End With
End Sub

サンプルプレイヤーデータ

名前	スピード	コーナー	スタミナ
高橋	70	21	9
野口	30	28	42
浅利	16	35	49
増田	33	33	34
谷川	14	26	60

プログラムコード

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Type Player
    Color As Integer
    Name As String
    Range As Range
    Muki As Integer
    EP As Integer
    SP As Integer
    TP As Integer
    RP As Integer
    ST As Integer
End Type

Private Const sleepTime As Long = 300           '少なくすると処理が早くなります。

Private p() As Player
Private pc As Integer                           'プレイヤー数
Private turn As Long
Private jyuni1 As Integer
Private jyuni2 As Integer
Private jyuni3 As Integer
Private jyuni4 As Integer
Private jyuni5 As Integer

Sub GameStart()
    '作業用
    Dim i As Integer
    Dim j As Integer
    Dim f As Boolean
    
    '初期化
    Range("A1:O20").Font.ColorIndex = 2
    Range("F6:J15").Font.ColorIndex = 50
    Range("V2:Z22").ClearContents
    
    Dim p(20) As Player
    
    jyuni1 = 1
    jyuni2 = 1
    jyuni3 = 1
    jyuni4 = 1
    jyuni5 = 1
    pc = 0
    i = 5
    j = 10
    While Cells(pc + 2, 18).Value <> ""
        p(pc).Color = pc + 3
        Cells(pc + 2, 17).Font.ColorIndex = pc + 3
        Cells(pc + 2, 17).Value = "●"
        p(pc).Name = Cells(pc + 2, 18).Value
        Set p(pc).Range = Cells(j, i)
        If i > 1 Then
            i = i - 1
        Else
            j = j - 1
            i = 5
        End If
        p(pc).Muki = 1
        p(pc).EP = Cells(pc + 2, 19).Value
        p(pc).SP = Cells(pc + 2, 20).Value
        p(pc).ST = Cells(pc + 2, 21).Value
        p(pc).RP = 0
        p(pc).Range.Font.ColorIndex = p(pc).Color
        p(pc).Range.Value = "●"
        pc = pc + 1
    Wend
    
    MsgBox "スタート"
    
    turn = 1
    f = True
    While f
        f = False
        For i = 0 To pc - 1
            If p(i).RP < 6 Then
                p(i).TP = p(i).TP + p(i).EP + 350 + Int(Rnd(-turn) * 100)
                If p(i).TP > 500 Then
                    p(i).TP = p(i).TP - 500
                    Call move1(p(i))
                    Debug.Print p(i).Muki
                End If
                f = True
            End If
        Next i
        DoEvents
        Sleep sleepTime
    Wend
    
    MsgBox "終了"
    
End Sub

Sub move1(p As Player)
    Dim r1 As Range
    Dim r2 As Range
    Dim r3 As Range
    
    turn = turn + 1
    Select Case p.Muki
        Case 1
            Set r1 = p.Range.Offset(1, 0)
            If p.Range.Column < 5 Then
                Set r2 = p.Range.Offset(1, 1)
            Else
                Set r2 = Nothing
            End If
            If p.Range.Column > 1 Then
                Set r3 = p.Range.Offset(1, -1)
            Else
                Set r3 = Nothing
            End If
            If p.Range.Row >= 15 Then
                If p.Range.Row = 19 Then
                    p.Muki = 2
                Else
                    If Rnd(-turn) * 200 < p.SP + 100 Then
                        p.Muki = 2
                    End If
                End If
            End If
        Case 2
            Set r1 = p.Range.Offset(0, 1)
            If p.Range.Row > 16 Then
                Set r2 = p.Range.Offset(-1, 1)
            Else
                Set r2 = Nothing
            End If
            If p.Range.Row < 20 Then
                Set r3 = p.Range.Offset(1, 1)
            Else
                Set r3 = Nothing
            End If
            If p.Range.Column >= 10 Then
                If p.Range.Column = 14 Then
                    p.Muki = 3
                Else
                    If Rnd(-turn) * 200 < p.SP + 100 Then
                        p.Muki = 3
                    End If
                End If
            End If
        Case 3
            Set r1 = p.Range.Offset(-1, 0)
            If p.Range.Column > 11 Then
                Set r2 = p.Range.Offset(-1, -1)
            Else
                Set r2 = Nothing
            End If
            If p.Range.Column < 15 Then
                Set r3 = p.Range.Offset(-1, 1)
            Else
                Set r3 = Nothing
            End If
            If p.Range.Row <= 6 Then
                If p.Range.Row = 2 Then
                    p.Muki = 4
                Else
                    If Rnd(-turn) * 200 < p.SP + 100 Then
                        p.Muki = 4
                    End If
                End If
            End If
        Case 4
            Set r1 = p.Range.Offset(0, -1)
            If p.Range.Row < 5 Then
                Set r2 = p.Range.Offset(1, -1)
            Else
                Set r2 = Nothing
            End If
            If p.Range.Row > 1 Then
                Set r3 = p.Range.Offset(-1, -1)
            Else
                Set r3 = Nothing
            End If
            If p.Range.Column <= 6 Then
                If p.Range.Column = 2 Then
                    p.Muki = 1
                Else
                    If Rnd(-turn) * 200 < p.SP + 100 Then
                        p.Muki = 1
                    End If
                End If
            End If
    End Select
    
    If r1.Font.ColorIndex = 2 Then
        p.Range.Font.ColorIndex = 2
        p.Range.Value = ""
        Set p.Range = r1
        Call GoleCheck(p)
    Else
        If Not r2 Is Nothing Then
            If r2.Font.ColorIndex = 2 Then
                p.Range.Font.ColorIndex = 2
                p.Range.Value = ""
                Set p.Range = r2
                Call GoleCheck(p)
            End If
        Else
            If Not r3 Is Nothing Then
                If r3.Font.ColorIndex = 2 Then
                    p.Range.Font.ColorIndex = 2
                    p.Range.Value = ""
                    Set p.Range = r3
                    Call GoleCheck(p)
                End If
            End If
        End If
    End If
    
End Sub

'ゴールしたかどうか
Sub GoleCheck(p As Player)
    If p.Muki = 1 And p.Range.Row = 11 Then
        p.RP = p.RP + 1
        Select Case p.RP
            Case 1
                p.Range.Font.ColorIndex = p.Color
                p.Range.Value = "●"
            Case 2
                Cells(p.Color - 1, 22).Value = jyuni1 & "位"
                jyuni1 = jyuni1 + 1
                p.Range.Font.ColorIndex = p.Color
                p.Range.Value = "●"
                 p.EP = p.EP - (100 - p.ST) / 2
           Case 3
                Cells(p.Color - 1, 23).Value = jyuni2 & "位"
                jyuni2 = jyuni2 + 1
                p.Range.Font.ColorIndex = p.Color
                p.Range.Value = "●"
                p.EP = p.EP - (100 - p.ST) / 2
            Case 4
                Cells(p.Color - 1, 24).Value = jyuni3 & "位"
                jyuni3 = jyuni3 + 1
                p.Range.Font.ColorIndex = p.Color
                p.Range.Value = "●"
                p.EP = p.EP - (100 - p.ST) / 2
            Case 5
                Cells(p.Color - 1, 25).Value = jyuni4 & "位"
                jyuni4 = jyuni4 + 1
                p.Range.Font.ColorIndex = p.Color
                p.Range.Value = "●"
                p.EP = p.EP - (100 - p.ST) / 2
            Case 6
                Cells(p.Color - 1, 26).Value = jyuni5 & "位"
                jyuni5 = jyuni5 + 1
        End Select
    Else
        p.Range.Font.ColorIndex = p.Color
        p.Range.Value = "●"
    End If
End Sub