マラソンゲーム２

マラソンゲーム２は人力検索とExcelを使った参加型ゲームです。
以前、行ったマラソンゲームに少し手を加えてみました。

第一弾　陣取りゲーム
http://q.hatena.ne.jp/1212842604
第二弾　マラソンゲーム
http://q.hatena.ne.jp/1213355560
第三弾　プロレスゲーム
http://q.hatena.ne.jp/1214797405

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

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

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

手順は、

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

画面作成コード

Sub MakeSheet()
    With ActiveSheet.Cells
        .RowHeight = 22.5
        .ColumnWidth = 3.13
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Bold = True
    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:V").ColumnWidth = 8
        .Columns("W:AA").ColumnWidth = 6.5
        .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 = "４週目"
        .Range("AA1").Value = "順位"
    End With
End Sub

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

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

プログラムコード

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       'スタミナ
    TB As Integer       'ターボを使う周
End Type

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

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
Private turb 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("W2:AA22").ClearContents
    
    ReDim 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).TB = Cells(pc + 2, 22).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 * 2 + 350
                If p(i).TB = p(i).RP Then
                    turb = 500
                Else
                    turb = 1000
                End If
                If p(i).TP > turb Then
                    p(i).TP = p(i).TP - turb
                    Call move1(p(i))
                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) * 100 < p.SP 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) * 100 < p.SP 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) * 100 < p.SP 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) * 100 < p.SP 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)
            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)
                    Else
                        p.TP = p.TP + turb * 0.7
                    End If
                End If
            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)
                Else
                    p.TP = p.TP + turb * 0.7
                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
                Call byouga(p)
            Case 2
                Cells(p.Color - 1, 23).Value = jyuni1 & "位"
                jyuni1 = jyuni1 + 1
                p.Range.Font.ColorIndex = p.Color
                Call byouga(p)
                p.EP = p.EP - (80 - p.ST) / 2
           Case 3
                Cells(p.Color - 1, 24).Value = jyuni2 & "位"
                jyuni2 = jyuni2 + 1
                p.Range.Font.ColorIndex = p.Color
                Call byouga(p)
                p.EP = p.EP - (80 - p.ST) / 2
            Case 4
                Cells(p.Color - 1, 25).Value = jyuni3 & "位"
                jyuni3 = jyuni3 + 1
                p.Range.Font.ColorIndex = p.Color
                Call byouga(p)
                p.EP = p.EP - (80 - p.ST) / 2
            Case 5
                Cells(p.Color - 1, 26).Value = jyuni4 & "位"
                jyuni4 = jyuni4 + 1
                p.Range.Font.ColorIndex = p.Color
                Call byouga(p)
                p.EP = p.EP - (80 - p.ST) / 2
            Case 6
                Cells(p.Color - 1, 27).Value = jyuni5 & "位"
                jyuni5 = jyuni5 + 1
        End Select
    Else
        p.Range.Font.ColorIndex = p.Color
        Call byouga(p)
    End If
End Sub

Sub byouga(p As Player)
    If p.TB = p.RP Then
        p.Range.Value = "○"
    Else
        p.Range.Value = "●"
    End If
End Sub

コードが少し長くなってきて、xlsファイルを配布するほうが簡単という意見もあるかもしれませんが、第３者が作ったマクロを実行することは危険を伴いますので、コードを公開するという形で対処しています。また、コードに触れることでExcelVBAに興味を持つ方が増えればいいですね。

ＶＢＡの使い方やゲームに関するルールなどわからないことがあれば、コメント欄でお聞きください。また、このコードに関しておかしなところがあれば、教えていただければ大変たすかります。