プロレスゲーム

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

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

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

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

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 = 30
        .ColumnWidth = 9.63
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Size = 11
        .Font.Bold = True
    End With
    With ActiveSheet
        .Columns("F:I").ColumnWidth = 4.75
        .Columns("K:K").ColumnWidth = 4.75
        .Columns("M:P").ColumnWidth = 6.88
        .Columns("Q:Q").ColumnWidth = 18
        .Range("A2:A3").MergeCells = True
        .Range("B2:B3").MergeCells = True
        .Range("D2:D3").MergeCells = True
        .Range("E2:E3").MergeCells = True
        .Range("A4:A5").MergeCells = True
        .Range("B4:B5").MergeCells = True
        .Range("D4:D5").MergeCells = True
        .Range("E4:E5").MergeCells = True
        .Range("C3:C4").MergeCells = True
        .Range("A7:A10").MergeCells = True
        .Range("B7:E10").MergeCells = True
        .Range("B11:E11").MergeCells = True
        .Range("B12:E12").MergeCells = True
        .Range("B13:E13").MergeCells = True
        .Range("B14:E14").MergeCells = True
        .Range("B15:E15").MergeCells = True
        .Range("B16:E16").MergeCells = True
        .Range("B17:E17").MergeCells = True
        Call Waku1(.Range("A2:B3"))
        Call Waku1(.Range("D2:E3"))
        Call Waku1(.Range("A4:B5"))
        Call Waku1(.Range("D4:E5"))
        Call Waku1(.Range("J2:J3"))
        Call Waku1(.Range("J4:J5"))
        Call Waku1(.Range("J6:J7"))
        Call Waku1(.Range("J8:J9"))
        Call Waku1(.Range("J10:J11"))
        Call Waku1(.Range("J12:J13"))
        Call Waku1(.Range("J14:J15"))
        Call Waku1(.Range("J16:J17"))
        Call Waku2(.Range("I3:I4"))
        Call Waku2(.Range("I7:I8"))
        Call Waku2(.Range("I11:I12"))
        Call Waku2(.Range("I15:I16"))
        Call Waku2(.Range("H4:H7"))
        Call Waku2(.Range("H12:H15"))
        Call Waku2(.Range("G6:G13"))
        With .Range("A7:E17")
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeTop).ColorIndex = xlAutomatic
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
            .Borders(xlEdgeRight).Weight = xlThin
            .Borders(xlEdgeRight).ColorIndex = xlAutomatic
            .Borders(xlInsideVertical).Weight = xlThin
            .Borders(xlInsideVertical).ColorIndex = xlAutomatic
            .Borders(xlInsideHorizontal).Weight = xlThin
            .Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
        End With
        With .Range("B7:E17")
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlTop
            .WrapText = True
        End With
        .Range("A7").WrapText = True
        .Range("A2:B5").Font.Size = 14
        .Range("D2:E5").Font.Size = 14
        .Range("C3:C4").Font.Size = 14
        .Range("J2:J17").Interior.ColorIndex = 34
        .Range("L1:Q1").Interior.ColorIndex = 36
        .Range("C3").Value = "VS"
        .Range("A11").Value = "第一試合"
        .Range("A12").Value = "第二試合"
        .Range("A13").Value = "第三試合"
        .Range("A14").Value = "第四試合"
        .Range("A15").Value = "準決勝" & vbNewLine & "第一試合"
        .Range("A16").Value = "準決勝" & vbNewLine & "第二試合"
        .Range("A17").Value = "決勝"
        .Range("L1").Value = "名前"
        .Range("M1").Value = "体力"
        .Range("N1").Value = "力"
        .Range("O1").Value = "技"
        .Range("P1").Value = "相性"
        .Range("Q1").Value = "必殺技"
    End With
End Sub

Sub Waku1(r As Range)
    r.Borders(xlEdgeTop).Weight = xlThin
    r.Borders(xlEdgeTop).ColorIndex = xlAutomatic
    r.Borders(xlEdgeLeft).Weight = xlThin
    r.Borders(xlEdgeLeft).ColorIndex = xlAutomatic
    r.Borders(xlEdgeBottom).Weight = xlThin
    r.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
    r.Borders(xlEdgeRight).Weight = xlThin
    r.Borders(xlEdgeRight).ColorIndex = xlAutomatic
End Sub

Sub Waku2(r As Range)
    r.Borders(xlEdgeTop).Weight = xlMedium
    r.Borders(xlEdgeTop).ColorIndex = 1
    r.Borders(xlEdgeLeft).Weight = xlMedium
    r.Borders(xlEdgeLeft).ColorIndex = 1
    r.Borders(xlEdgeBottom).Weight = xlMedium
    r.Borders(xlEdgeBottom).ColorIndex = 1
End Sub

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

名前	体力	力	技	相性	必殺技
猪木	30	30	40	80	卍固め
馬場	40	30	30	20	１６文キック
長州	10	70	20	10	ラリアット
武藤	80	10	10	80	チョークスリーパー
ライガー	30	50	20	30	頭突き
タイガー	40	50	10	20	浣腸
小橋	10	10	80	70	マッハパンチ
蝶野	30	30	40	20	黒龍破

プログラムコード

Option Explicit

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

Private Type Player
    Name As String      '名前
    HP As Integer       '体力
    AP As Integer       '力
    WP As Integer       '技
    WName As String     '必殺技名
    IP As Integer       '相性値
    MHP As Integer      '最大体力
End Type

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

Private p() As Player
Private turn As Long                            '擬似乱数用
Private myLog(6) As String                      'ログ保存用
Private logCount As Integer
Private blHissatu As Boolean                    '必殺技かどうか

Sub GameStart()
    ReDim p(17) As Player
    Dim win As Integer
    Dim k1 As Integer
    Dim k2 As Integer
    Dim j1 As Integer
    Dim j2 As Integer
    Dim j3 As Integer
    Dim j4 As Integer
    Dim i As Integer
    
    '初期化
    Range("B7:E17").Value = ""
    Range("A2:E5").Interior.ColorIndex = xlNone
    turn = 0
    logCount = 0
    
    'データ読み込み
    i = 2
    While Cells(i, 12).Value <> ""
        p(i - 2).Name = Cells(i, 12).Value
        p(i - 2).MHP = Cells(i, 13).Value * 5 + 500
        p(i - 2).HP = p(i - 2).MHP
        p(i - 2).AP = Cells(i, 14).Value
        p(i - 2).WP = Cells(i, 15).Value
        p(i - 2).IP = Cells(i, 16).Value
        turn = turn + p(i - 2).IP
        p(i - 2).WName = Cells(i, 17).Value
        i = i + 1
    Wend
     
    'トーナメント表の作成
    Cells(2, 10).Value = p(0).Name
    Cells(3, 10).Value = p(1).Name
    Cells(16, 10).Value = p(2).Name
    Cells(17, 10).Value = p(3).Name
    Cells(10, 10).Value = p(4).Name
    Cells(11, 10).Value = p(5).Name
    Cells(8, 10).Value = p(6).Name
    Cells(9, 10).Value = p(7).Name
    Cells(6, 10).Value = p(8).Name
    Cells(7, 10).Value = p(9).Name
    Cells(12, 10).Value = p(10).Name
    Cells(13, 10).Value = p(11).Name
    Cells(14, 10).Value = p(12).Name
    Cells(15, 10).Value = p(13).Name
    Cells(4, 10).Value = p(14).Name
    Cells(5, 10).Value = p(15).Name
    Call Tornament1
    
    'トーナメント開始
    j1 = Play1(0, 1, 14, 15, "第一試合")
    If j1 = 0 Then
        Range("I3").Borders(xlEdgeTop).ColorIndex = 3
        Range("I3").Borders(xlEdgeLeft).ColorIndex = 3
    Else
        Range("I4").Borders(xlEdgeBottom).ColorIndex = 3
        Range("I4").Borders(xlEdgeLeft).ColorIndex = 3
    End If
    Range("H4").Borders(xlEdgeTop).ColorIndex = 3
    
    j2 = Play1(8, 9, 6, 7, "第二試合")
    If j2 = 8 Then
        Range("I7").Borders(xlEdgeTop).ColorIndex = 3
        Range("I7").Borders(xlEdgeLeft).ColorIndex = 3
    Else
        Range("I8").Borders(xlEdgeBottom).ColorIndex = 3
        Range("I8").Borders(xlEdgeLeft).ColorIndex = 3
    End If
    Range("H8").Borders(xlEdgeTop).ColorIndex = 3
    
    j3 = Play1(4, 5, 10, 11, "第三試合")
    If j3 = 4 Then
        Range("I11").Borders(xlEdgeTop).ColorIndex = 3
        Range("I11").Borders(xlEdgeLeft).ColorIndex = 3
    Else
        Range("I12").Borders(xlEdgeBottom).ColorIndex = 3
        Range("I12").Borders(xlEdgeLeft).ColorIndex = 3
    End If
    Range("H12").Borders(xlEdgeTop).ColorIndex = 3
    
    j4 = Play1(12, 13, 2, 3, "第四試合")
    If j4 = 12 Then
        Range("I15").Borders(xlEdgeTop).ColorIndex = 3
        Range("I15").Borders(xlEdgeLeft).ColorIndex = 3
    Else
        Range("I16").Borders(xlEdgeBottom).ColorIndex = 3
        Range("I16").Borders(xlEdgeLeft).ColorIndex = 3
    End If
    Range("H16").Borders(xlEdgeTop).ColorIndex = 3
    
    k1 = Play1(j1, j1 + 1, j2, j2 + 1, "準決勝　　第一試合")
    If k1 = 0 Or k1 = 14 Then
        Range("H4:H5").Borders(xlEdgeLeft).ColorIndex = 3
    Else
        Range("H6:H7").Borders(xlEdgeLeft).ColorIndex = 3
    End If
    Range("G6").Borders(xlEdgeTop).ColorIndex = 3
    
    k2 = Play1(j3, j3 + 1, j4, j4 + 1, "準決勝　 第二試合")
    If k2 = 4 Or k2 = 10 Then
        Range("H12:H13").Borders(xlEdgeLeft).ColorIndex = 3
    Else
        Range("H14:H15").Borders(xlEdgeLeft).ColorIndex = 3
    End If
    Range("G14").Borders(xlEdgeTop).ColorIndex = 3
    
    win = Play1(k1, k1 + 1, k2, k2 + 1, "決勝")
    If win = 0 Or win = 14 Or win = 8 Or win = 6 Then
        Range("G6:G9").Borders(xlEdgeLeft).ColorIndex = 3
    Else
        Range("G10:G13").Borders(xlEdgeLeft).ColorIndex = 3
    End If
    
    MsgBox p(win).Name & "・" & p(win + 1).Name & "の優勝です", , "結果"
    
    'ログの作成
    For i = 0 To 6
        Cells(i + 11, 2).Value = myLog(i)
    Next i

End Sub

'不戦勝かどうかの判定
Function Play1(p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, siai As String) As Integer
    Dim j As Integer
    
    p(p1).HP = p(p1).MHP
    p(p2).HP = p(p2).MHP
    p(p3).HP = p(p3).MHP
    p(p4).HP = p(p4).MHP

    Range("A2").Value = p(p1).Name
    Range("A4").Value = p(p2).Name
    Range("B2").Value = p(p1).HP
    Range("B4").Value = p(p2).HP
    Range("D2").Value = p(p3).Name
    Range("D4").Value = p(p4).Name
    Range("E2").Value = p(p3).HP
    Range("E4").Value = p(p4).HP
    Range("A7").Value = siai
    
    If p(p1).HP = 0 And p(p2).HP = 0 Then
        If p(p3).HP = 0 And p(p4).HP = 0 Then
            MsgBox "試合無し", , siai
            myLog(logCount) = "試合無し"
            logCount = logCount + 1
            j = 16
        Else
            MsgBox p(p3).Name & "・" & p(p4).Name & "不戦勝", , siai
            myLog(logCount) = p(p3).Name & "・" & p(p4).Name & "不戦勝"
            logCount = logCount + 1
            j = p3
        End If
    Else
        If p(p3).HP = 0 And p(p4).HP = 0 Then
            MsgBox p(p1).Name & "・" & p(p2).Name & "不戦勝", , siai
            myLog(logCount) = p(p1).Name & "・" & p(p2).Name & "不戦勝"
            logCount = logCount + 1
            j = p1
        Else
            j = Play2(p1, p2, p3, p4, siai)
        End If
    End If
    Play1 = j
End Function

'各試合
Function Play2(p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, siai As String) As Integer
    Dim mes As String
    Dim pL As Integer
    Dim pR As Integer
    Dim i As Integer
    Dim f As Boolean
       
    MsgBox p(p1).Name & "・" & p(p2).Name & vbNewLine & "       VS" & vbNewLine & _
        p(p3).Name & "・" & p(p4).Name & vbNewLine & vbNewLine & "     試合開始！", , siai
    
    If Rnd(-turn) * 2 > 1 Then
        pL = p1
        Range("A2:B3").Interior.ColorIndex = 35
        Range("A4:B5").Interior.ColorIndex = 2
    Else
        pL = p2
        Range("A2:B3").Interior.ColorIndex = 2
        Range("A4:B5").Interior.ColorIndex = 35
    End If
    turn = turn + p(p3).IP
    If Rnd(-turn) * 2 > 1 Then
        pR = p3
        Range("D2:E3").Interior.ColorIndex = 35
        Range("D4:E5").Interior.ColorIndex = 2
    Else
        pR = p4
        Range("D2:E3").Interior.ColorIndex = 2
        Range("D4:E5").Interior.ColorIndex = 35
    End If
    
    
    Do
        If f = True Or Rnd(-turn) * 2 > 1 Then
            Range("B7").Value = Atack(pL, pR)
            mes = mes & vbNewLine & Range("B7").Value
            Range("E2").Value = p(p3).HP
            Range("E4").Value = p(p4).HP
            Sleep (sleepTime)
            If blHissatu Then Sleep (sleepTime * 2)
            If p(pR).HP = 0 Then
                If p(p3).HP = 0 Then
                    If p(p4).HP = 0 Then
                        mes = mes & vbNewLine & p(p1).Name & "・" & p(p2).Name & "の勝利です。"
                        MsgBox p(p1).Name & "・" & p(p2).Name & "の勝利です。", , siai
                        mes = p(p1).Name & "・" & p(p2).Name & "VS" & p(p3).Name & "・" & p(p4).Name & _
                            vbNewLine & p(p1).Name & "・" & p(p2).Name & "の勝利" & vbNewLine & mes
                        myLog(logCount) = mes
                        logCount = logCount + 1
                        Play2 = p1
                        Exit Function
                    Else
                        Sleep (sleepTime)
                        pR = p4
                        Range("B7").Value = p(p4).Name & "がリングにあがった。"
                        Range("D2:E3").Interior.ColorIndex = 2
                        Range("D4:E5").Interior.ColorIndex = 35
                    End If
                Else
                    Sleep (sleepTime)
                    pR = p3
                    Range("B7").Value = p(p3).Name & "がリングにあがった。"
                    Range("D2:E3").Interior.ColorIndex = 35
                    Range("D4:E5").Interior.ColorIndex = 2
                End If
                mes = mes & vbNewLine & Range("B7").Value
            End If
            If p(pR).HP < 300 And Rnd(-turn) * 4 > 1 Then
                If pR = p3 Then
                    If p(p4).HP > 0 Then
                        Sleep (sleepTime)
                        pR = p4
                        Range("B7").Value = p(p3).Name & "は" & p(p4).Name & "にタッチした。"
                        Range("D2:E3").Interior.ColorIndex = 2
                        Range("D4:E5").Interior.ColorIndex = 35
                        mes = mes & vbNewLine & Range("B7").Value
                    End If
                Else
                    If p(p3).HP > 0 Then
                        Sleep (sleepTime)
                        pR = p3
                        Range("B7").Value = p(p4).Name & "は" & p(p3).Name & "にタッチした。"
                        Range("D2:E3").Interior.ColorIndex = 35
                        Range("D4:E5").Interior.ColorIndex = 2
                        mes = mes & vbNewLine & Range("B7").Value
                    End If
                End If
            End If
        End If
        f = True
        
        Range("B7").Value = Atack(pR, pL)
        mes = mes & vbNewLine & Range("B7").Value
        Range("B2").Value = p(p1).HP
        Range("B4").Value = p(p2).HP
        Sleep (sleepTime)
        If blHissatu Then Sleep (sleepTime * 2)
        If p(pL).HP = 0 Then
            If p(p1).HP = 0 Then
                If p(p2).HP = 0 Then
                    mes = mes & vbNewLine & p(p3).Name & "・" & p(p4).Name & "の勝利です。"
                    MsgBox p(p3).Name & "・" & p(p4).Name & "の勝利です。", , siai
                    mes = p(p1).Name & "・" & p(p2).Name & "VS" & p(p3).Name & "・" & p(p4).Name & _
                        vbNewLine & p(p3).Name & "・" & p(p4).Name & "の勝利" & vbNewLine & mes
                    myLog(logCount) = mes
                    logCount = logCount + 1
                    Play2 = p3
                    Exit Function
                Else
                    Sleep (sleepTime)
                    pL = p2
                    Range("B7").Value = p(p2).Name & "がリングにあがった。"
                    Range("A2:B3").Interior.ColorIndex = 2
                    Range("A4:B5").Interior.ColorIndex = 35
               End If
            Else
                Sleep (sleepTime)
                pL = p1
                Range("B7").Value = p(p1).Name & "がリングにあがった。"
                Range("A2:B3").Interior.ColorIndex = 35
                Range("A4:B5").Interior.ColorIndex = 2
            End If
            mes = mes & vbNewLine & Range("B7").Value
        End If
        If p(pL).HP < 300 And Rnd(-turn) * 4 > 1 Then
            If pL = p1 Then
                If p(p2).HP > 0 Then
                    Sleep (sleepTime)
                    pL = p2
                    Range("B7").Value = p(p1).Name & "は" & p(p2).Name & "にタッチした。"
                    Range("A2:B3").Interior.ColorIndex = 2
                    Range("A4:B5").Interior.ColorIndex = 35
                    mes = mes & vbNewLine & Range("B7").Value
                End If
            Else
                If p(p1).HP > 0 Then
                    Sleep (sleepTime)
                    pL = p1
                    Range("B7").Value = p(p2).Name & "は" & p(p1).Name & "にタッチした。"
                    Range("A2:B3").Interior.ColorIndex = 35
                    Range("A4:B5").Interior.ColorIndex = 2
                    mes = mes & vbNewLine & Range("B7").Value
                End If
            End If
        End If
        
        DoEvents
    Loop
End Function

'各攻撃
Function Atack(p1 As Integer, p2 As Integer) As String
    Dim dam As Integer
    Dim mes As String
    Dim p3 As Integer
    blHissatu = False
    turn = turn + p(p1).HP
    Select Case Int(Rnd(-turn) * 100)
        Case Is < 20
            If p1 Mod 2 = 0 Then
                p3 = p1 + 1
            Else
                p3 = p1 - 1
            End If
            If p(p1).HP < 300 And p(p3).HP < 300 And p(p3).HP > 0 Then
                dam = 2 * (p(p1).WP + p(p3).WP + 50) * (2 - 3 * Abs(p(p1).IP - p(p3).IP) / 200)
                mes = p(p3).Name & "が乱入した。" & vbNewLine & _
                    p(p1).Name & "と" & p(p3).Name & "は合体技" & p(p1).WName & p(p3).WName & "を出した。" & _
                    p(p2).Name & "に" & dam & "のダメージを与えた。"
            Else
                dam = 100 * (p(p1).WP * 2 + 100) / 100
                mes = p(p1).Name & "は必殺技" & p(p1).WName & "を出した。" & p(p2).Name & "に" & dam & "のダメージを与えた。"
            End If
            blHissatu = True
        Case Is < 40
            dam = 70 * (p(p1).AP + 100) / 100
            mes = p(p1).Name & "のコブラツイストが" & p(p2).Name & "を締め付ける。" & dam & "のダメージを与えた。"
        Case Is < 55
            dam = 45 * (p(p1).AP + 100) / 100
            mes = p(p1).Name & "のラリアットが" & p(p2).Name & "を襲う。" & dam & "のダメージを与えた。"
        Case Is < 75
            dam = 25 * (p(p1).AP + 100) / 100
            mes = p(p1).Name & "のドロップキックが" & p(p2).Name & "にヒット。" & dam & "のダメージを与えた。"
        Case Else
            dam = 10 * (p(p1).AP + 100) / 100
            mes = p(p1).Name & "のチョップが炸裂。" & p(p2).Name & "に" & dam & "のダメージを与えた。"
    End Select
    p(p2).HP = p(p2).HP - Int(dam)
    If p(p2).HP <= 0 Then
        p(p2).HP = 0
        mes = mes & vbNewLine & p(p2).Name & "は倒された。"
    End If
        
    Atack = mes
End Function

'トーナメント表の初期化
Sub Tornament1()
    Call Tornament2(Range("I3:I4"))
    Call Tornament2(Range("I7:I8"))
    Call Tornament2(Range("I11:I12"))
    Call Tornament2(Range("I15:I16"))
    Call Tornament2(Range("H4:H7"))
    Call Tornament2(Range("H12:H15"))
    Call Tornament2(Range("G6:G13"))
End Sub

Sub Tornament2(r As Range)
    r.Borders(xlEdgeTop).Weight = xlMedium
    r.Borders(xlEdgeTop).ColorIndex = 1
    r.Borders(xlEdgeLeft).Weight = xlMedium
    r.Borders(xlEdgeLeft).ColorIndex = 1
    r.Borders(xlEdgeBottom).Weight = xlMedium
    r.Borders(xlEdgeBottom).ColorIndex = 1
End Sub

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