どーも 暇人プログラマーTakeです。

今回も暇すぎて、Excel でトランプを使った「神経衰弱」を作ってみました！！

作成時間はおよそ３時間くらいでした！

わたしは要領が悪いので、作成に結構時間がかかってしまいました。。。

たぶんプログラミングが得意な人はもっと早くできると思います。

この記事では、私が作成した「神経衰弱」の操作方法と作成方法についてご紹介します～！

操作方法

操作方法は下記手順です。

簡単に言うと、設定することして、ボタンを押下すれば、

あとは普通の「神経衰弱」です。

数字の種類（２～１３）

ゲームに使うトランプの数字の種類のことを指します。

たとえば、数字の種類（２～１３）＝ 3 と設定すれば、

トランプの数字（2 ~10、J、Q、K）のうち3種類の数字（たとえば、２、４、Jの3種類）

を使うように設定するということです（この数値はランダムで決定します）。

マークの種類（♥ ♠ ♦ ♣）

ゲームに使うトランプのマークの種類のことです。

これは、「2」か「4」のみ設定できるのですが、

「2」と設定すると、♥ ♠の2種類、「4」と設定すると、♥ ♠ ♦ ♣の4種類が

神経衰弱のゲーム内で使用されるということです。

配置されるカードの枚数について

また配置されるカードの枚数ですが、

数字の種類（２～１３）×記号の種類（♥ ♠ ♦ ♣）の枚数になります。

つまり、最大が１3×4枚＝52 枚となります。

「START」と「FIN」ボタンについて

「START」ボタンを押下することで、ゲームが開始されます。

その際に「ステータス」という箇所が「ゲーム中」に変更されるのが確認できます。

また、トランプが表示されることが確認でき、押下も可能です（画面赤色のセルの箇所）。

「FIN」ボタンを押下することで、ゲームが終了します。

その際に「ステータス」という箇所が「ゲーム終了」に変更されるのが確認できます。

なお「ゲーム終了」状態では、カードを押下しても反応しなくなります。

作成方法

今回は、Excel Vba を用いて作成しました！

作成方法について、全部記述すると長くなるのですがご容赦ください。

※ 専門的な用語もでてきますので、よくわかない方は、ページの一番下のダウンロードボタンから

Excel「神経衰弱」をダウンロードして遊んでみてください！

シート構成

「神経衰弱」はメインシートであるので、実施に神経衰弱を行う用のシートとなります。

実装自体は Excel Vba で行っており、このシートはその実装結果を表示させているだけです。

「トランプマスタ」はトランプに関する情報を登録するシートです。

具体的には、トランプで使用する数字とマークをどういうものを使用するかといったことを登録しています。

この値を参照してトランプとして扱う数字とマークを設定するように Excel Vba 上で動作させています。

作業用シートは実際に神経衰弱のゲームを行っていく上で必要な情報を登録するシートです。

具体的には下記情報を登録しています。

ソースコード

Excel Vba のソースコードについては下記のような構成になっています。

Sheet1(神経衰弱)

ここはシート上のクリックを検知し、その検知した結果、さまざまな処理を行う箇所です。

具体的には、カードを配置する範囲のセルがクリックされている状態で

かつステータスが「ゲーム中」の場合にクリックが検知された場合に様々な処理を行うようにしています。

ソースコード

'シート操作の処理
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim NowCell
    Set NowCell = ActiveCell
    Dim GameStatus
    GameStatus = Worksheets(WORK_SHEET).Range(GAME_STATUS_PLACE).Value

    If GameStatus = MSG_GAME_START _
        And BOARD_Y <= NowCell.Row And NowCell.Row <= BOARD_Y + 8 _
        And BOARD_X <= NowCell.Column And NowCell.Column <= BOARD_X + 20 _
        And NowCell.Value <> "" _
    Then
        
        ' カード押下前の処理
        Call prepareCard(NowCell, NowCell.Address)
        
        ' カード押下時の処理
        Call openCard(NowCell)
        
        ' カード押下後の処理
        Call pushCard(NowCell.Value, NowCell.Address)
        
        'カード終了時のフラグ
        Call finGame
    
    End If
    
End Sub

※ Excel シートのクリック検知について記事を以前記事を作成しましたの、よければ参考にご確認ください。

（わたしは以前これを知らなくてめちゃくちゃ悩んだ覚えがありますが、知っていれば超簡単です！）

【Excel vba】マウスの左クリックのイベントを検知する簡単な方法

2019.2.4

はじめに Excelで将棋のゲームをつくろうとしたときでした。 そういやどうやってマウスクリックを検知すればいいんやろう？ 私は仕事やブログでExcelを取り扱うことが多いですが、セルをクリックしたときにクリックしたことを検知しそこから処理を開始することがわかりませんでした。 いろいろ調べましたが、...

STARTボタン押下処理

ここでは、START ボタンが押下された場合の処理をまとめています。

私が作成したマクロは、STARTボタンを押下することでゲームが開始する仕様になっていますが、

ゲーム開始前の準備をここでは行うということです。

ソースコード

' START ボタン押下処理
Sub main()

    Application.ScreenUpdating = False
    
    Dim numArray
    
    ' メインシート 初期化
    Call setDefaultMainSheet

    ' メインシート 初期化
    Call setDefaultWorkSheet
    
    ' 配置するカードを設定
    numArray = setCard
   
    ' 盤上にカードをセット
    Call setBorad(numArray)

    ' ゲームステータス
    Worksheets(WORK_SHEET).Range(GAME_STATUS_PLACE).Value = MSG_GAME_START

    Application.ScreenUpdating = True

End Sub

' メインシート 初期化
Sub setDefaultMainSheet()

  With Worksheets(MAIN_SHEET)
    
    .Range(Cells(BOARD_Y, X + BOARD_X), Cells(BOARD_Y + 20, X + BOARD_X + 20)).Clear
  
  End With

End Sub


' 作業用シート 初期化
Sub setDefaultWorkSheet()

  With Worksheets(WORK_SHEET)
    
    .Range(FIRST_INFO_PLACE).ClearContents
    .Range(SECOND_INFO_PLACE).ClearContents
    .Range(FIRST_CELL_PLACE).ClearContents
    .Range(SECOND_CELL_PLACE).ClearContents
        
  End With

End Sub

カード押下時の処理

シート上の赤いセルをクリックした場合に実装される処理です。

Sheet1(神経衰弱)で動作を検知し、このソースコードに書かれたプロシージャが実行されるということです。

カード押下前の処理

ここでは、まず一枚目と二枚目のカードが押下されたセルの情報（セルの値とセルの位置）を

「作業用シート」に記述します。

カード押下時の処理

押下されたセルの配色を変更します。

赤色のカードとは、つまり赤色の背景色のセル（セル内の文字も赤色）ということですが、

カードが押下されたということが、カードを開く（表返す）ためにセルの背景色を赤色から白色に変更しています。

また、この際に、♥と♦のマークを赤色、♠と♣を黒色にするように表示します。

（下記はかなり悩んだところなんですが。。。）

Excel Vbaでは、 ♥♠♦♣という文字が読み取れません。

読み取ろうとすると「?」となってしまいます（Excel 2016ではそうなりました。。）。

ですので、今回の対策として、

カード押下後の処理

ここでは、カードが二枚クリックされたかを判定し、

判定した結果、同じ数字であるかそうでないかを比較し、同じならカードを削除します。

判定方法は、「作業用シート」のB2、C2の値が両方空白かどうかで判定します。

両方とも値が含まれていれば、二枚クリックされたということです。

数字の比較については、「作業用シート」のB2、C2の値を比較しますが、

このときカードのマーク無視するようにします（つまり一番最後の文字を無視して数字部分のみ判定します）。

ソースコード

Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)

' カード押下前の処理
Sub prepareCard(ByVal CardInfo, ByVal CardAddress)

    Dim firstCard
    Dim secondCard
    Dim firstPlace
    Dim secondPlace
        
    firstCard = Worksheets(WORK_SHEET).Range(FIRST_INFO_PLACE).Value
    secondCard = Worksheets(WORK_SHEET).Range(SECOND_INFO_PLACE).Value


    ' 1枚目が押下されたとき
    If firstCard = "" Then
        
        Worksheets(WORK_SHEET).Range(FIRST_INFO_PLACE).Value = CardInfo
        Worksheets(WORK_SHEET).Range(FIRST_CELL_PLACE).Value = CardAddress
        
    ' 2枚目が押下されたとき
    ElseIf secondCard = "" Then
    
        Worksheets(WORK_SHEET).Range(SECOND_INFO_PLACE).Value = CardInfo
        Worksheets(WORK_SHEET).Range(SECOND_CELL_PLACE).Value = CardAddress

    End If

End Sub

' カード押下時の処理
Sub openCard(ByRef CellValue)

    Dim inputValue
    Dim cardValueLast
    
    inputValue = ouputVlookup(CellValue)
    cardValueLast = Right(CellValue, 1)
    
    With CellValue
        .Value = inputValue
        .Borders.LineStyle = xlContinuous
        .Borders.Color = RGB(255, 0, 0)
        .Interior.ColorIndex = CARD_COLOR_WHITE
        
        If cardValueLast = "H" Or cardValueLast = "D" Then
            .Font.ColorIndex = CARD_COLOR_RED
        Else
            .Font.ColorIndex = CARD_COLOR_BLACK
        End If

    End With
              
End Sub

' カード押下後の処理
Sub pushCard(ByVal CardInfo, ByVal CardAddress)

    Dim firstCard
    Dim secondCard
    Dim firstPlace
    Dim secondPlace
        
    firstCard = Worksheets(WORK_SHEET).Range(FIRST_INFO_PLACE).Value
    secondCard = Worksheets(WORK_SHEET).Range(SECOND_INFO_PLACE).Value

    firstPlace = Worksheets(WORK_SHEET).Range(FIRST_CELL_PLACE).Value
    secondPlace = Worksheets(WORK_SHEET).Range(SECOND_CELL_PLACE).Value

    ' 1枚目が押下されたとき
    If secondCard <> "" Then
            
        Sleep WAIT_TIME
        
        ' カードが同じとき
        If Worksheets(WORK_SHEET).Range(JUDGE_PLACE).Value = 1 _
        And firstPlace <> secondPlace _
        Then
            
            Call deleteCard(firstPlace)
            Call deleteCard(secondPlace)

        ' カードが違うとき
        Else

            Call backCard(firstPlace, firstCard)
            Call backCard(secondPlace, secondCard)
                    
        End If
        
        ' 作業用シート 初期化
        Call setDefaultWorkSheet
        
    End If
   
End Sub


' 違うカードをもとに戻す（ひっくり返す）
Private Sub backCard(ByVal CardPlace, ByVal CardValue)

    Application.ScreenUpdating = False
    
    With Worksheets(MAIN_SHEET).Range(CardPlace)
        
        .Value = CardValue
        .ColumnWidth = CARD_HEIGHT
        .RowHeight = CARD_WIDTH
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.ColorIndex = CARD_COLOR_RED
        .Interior.ColorIndex = CARD_COLOR_RED
    
    End With
    
    Application.ScreenUpdating = True

End Sub

' 同じカードの場合削除する
Private Sub deleteCard(ByVal CardPlace)

    With Worksheets(MAIN_SHEET).Range(CardPlace)
        
        .ClearContents
        .ColumnWidth = CARD_HEIGHT
        .RowHeight = CARD_WIDTH
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.ColorIndex = CARD_COLOR_WHITE
        .Interior.ColorIndex = CARD_COLOR_WHITE
    
    End With

End Sub

ゲーム終了処理

ここでは、ゲーム終了処理に関する処理が含まれます。

ゲームが終了するパターンは主に2通りです。

①のすべてカードがめくられたときの検知方法ですが、

二枚目のカードがクリックされた後に

作業用シートの「残り枚数」と記載のある個所（F2）が０になったときに終了するように処理します。

ソースコード

'ゲーム終了処理
Sub finGame()
    
    Dim finFlag
    
    finFlag = Worksheets(WORK_SHEET).Range(REMAIN_CARD_NUM).Value
    
    If finFlag = 0 Then
    
        MsgBox MSG_FIN_GAME
        
        Worksheets(WORK_SHEET).Range(GAME_STATUS_PLACE).Value = MSG_GAME_END

    End If
    
End Sub

'ゲーム終了押下
Sub pushFinGame()
            
    Worksheets(WORK_SHEET).Range(GAME_STATUS_PLACE).Value = MSG_GAME_END
    
End Sub

定数定義

ここでは、Excel Vba で扱う定数についてまとめて定義しています。

シート名、カードを配置する箇所（盤上という表現で記載）などなどです。

（たぶん、ソースコード見たほうがはやいとおもいます。）

ソースコード

' --- シート情報 ---

Public Const MAIN_SHEET As String = "神経衰弱"
Public Const MASTER_SHEET As String = "トランプマスタ"
Public Const WORK_SHEET As String = "作業用"


' --- 「神経衰弱」シート ---

' データの範囲 盤上の設定
Public Const BOARD_X As Integer = 3
Public Const BOARD_Y As Integer = 6

Public Const SET_NUM_MAIN_RANGE As String = "F3"
Public Const SET_KIGO_MAIN_RANGE As String = "L3"

' カード情報
Public Const CARD_HEIGHT As Integer = 5
Public Const CARD_WIDTH As Integer = 50
Public Const CARD_COLOR_RED As Integer = 3
Public Const CARD_COLOR_WHITE As Integer = 2
Public Const CARD_COLOR_BLACK As Integer = 1

' --- 「トランプマスタ」シート ---

Public Const MASTER_RANGE As String = "A2:B5"


' --- 「作業用」シート ---

' 残りカード枚数
Public Const REMAIN_CARD_NUM As String = "F2"

' 押下カードの情報
Public Const FIRST_INFO_PLACE As String = "B2"
Public Const SECOND_INFO_PLACE As String = "C2"

Public Const FIRST_CELL_PLACE As String = "B3"
Public Const SECOND_CELL_PLACE As String = "C3"

' カードが一致するか
Public Const JUDGE_PLACE As String = "D2"

' カードをもとに戻す時間
Public Const WAIT_TIME As Integer = 1000

' ゲームステータス確認
Public Const GAME_STATUS_PLACE As String = "H2"

' --- その他 ---

' 判定フラグ
Public Const PUSH_FIRST_CARD As Integer = 0
Public Const PUSH_SECOND_CARD_SAME As Integer = 1
Public Const PUSH_SECOND_CARD_DIFF As Integer = 2


' --- メッセージ ----

' ゲームステータス
Public Const MSG_GAME_START As String = "ゲーム中"
Public Const MSG_GAME_END As String = "ゲーム終了"

' ゲーム終了時
Public Const MSG_FIN_GAME As String = "お疲れ様でした！！ゲームを終了します！！"

' VLOOKUPの出力
Function ouputVlookup(ByVal Str)

    ouputVlookup = "=VLOOKUP(""" & Str & """,トランプマスタ!I:K,3,FALSE)"

End Function

配置カードを設定

ここでは「START」ボタン押下時にはじめにカードを配置する処理を記述しています。

大きくは setCard() プロシージャで処理を実装しています。

ちょっとわかりにくかったかもなので、補足します。

はじめに「神経衰弱」シートで「３種類」の数字と「４種類」のマークを使用するとします。

つぎに「３種類」の数字の中からどの数字にするか（1 ~ 10の中で）ランダムに選択します。

たとえば、1、４、９と使うとすると

１、４、９ ×　「４種類」のマーク♥♠♦♣ = 12種類の文字列を作成し、配列に格納します。

そして最終的に配列をランダムにシャッフルし、その配列をシートに出力するということです。

※ ここでは、配列の生成のみで、シートへの出力は別の「盤上へカードを配置」で行います。

ソースコード

' ゲームで使うカードの設定
' 数字 + 記号を文字列を含む配列で返す

Function setCard() As String()

    Dim numArray
    Dim allCardArray
    Dim setCardNumber As Integer
    
    ' 何種類の数字をゲームをするか
    setCardNumber = Worksheets(MAIN_SHEET).Range(SET_NUM_MAIN_RANGE)
    
    ' 上記の種類のランダム数字で決定
    numArray = getCardArray(setCardNumber)
    
    ' 最終的に使うカードの種類を決定
    setCard = decideCardArray(numArray)
    
End Function

' 上記の種類のランダム数字で決定
Private Function getCardArray(ByRef Num As Integer) As String()

    Dim i As Long
    Dim myNum As Long
    Dim numArray() As String
    Dim myFlag(1 To 13) As Boolean

    '乱数系列を初期化
    Randomize
    
    For i = 1 To Num
        Do
            myNum = Int((13 - 1 + 1) * Rnd + 1)
        Loop Until myFlag(myNum) = False
        
        ReDim Preserve numArray(i - 1)
        numArray(i - 1) = myNum
        myFlag(myNum) = True
    Next i

    getCardArray = numArray

End Function


' 最終的に使うカードの種類を決定
Private Function decideCardArray(ByRef numArray) As String()
    
    Dim i As Integer: i = 0
    Dim sumArray() As String
    Dim kigoMaster: kigoMaster = Worksheets(MASTER_SHEET).Range(MASTER_RANGE)
    Dim kigoNum: kigoNum = Worksheets(MAIN_SHEET).Range(SET_KIGO_MAIN_RANGE)

    For Each Var In numArray
        
        ReDim Preserve sumArray(i)
        sumArray(i) = Var & kigoMaster(1, 1)
        i = i + 1
        ReDim Preserve sumArray(i)
        sumArray(i) = Var & kigoMaster(2, 1)
        i = i + 1
        
        If kigoNum = 4 Then
            ReDim Preserve sumArray(i)
            sumArray(i) = Var & kigoMaster(3, 1)
            i = i + 1
            ReDim Preserve sumArray(i)
            sumArray(i) = Var & kigoMaster(4, 1)
            i = i + 1
        End If
    
    Next Var

    decideCardArray = cardShuffle(sumArray)

End Function

' カードをシャッフル
Private Function cardShuffle(ByRef cardArray) As String()

    For i = 0 To UBound(cardArray)
        Randomize
        rn = Int(UBound(cardArray) * Rnd)
        tmp = cardArray(i)
        cardArray(i) = cardArray(rn)
        cardArray(rn) = tmp
    Next
    
    cardShuffle = cardArray

End Function

盤上へカードを配置

「配置カードを設定」で生成した配列をシートに表示させます。

その表示の際に、カードの装飾も行っています。

カードの装飾とはつまりセルの配色を指します（たとえば、セルの値、罫線、背景色など）。

ソースコード

' 盤上へカードを配置
Sub setBorad(ByRef numArray)

    Dim X: X = 0
    Dim Y: Y = 0
    Dim j: j = 0
    
    Dim arraylength: arraylength = UBound(numArray) + 1
    
    Do
        ' カードの装飾
        Call paintCard(numArray(j), X + BOARD_X, Y + BOARD_Y)
        
        If X >= 20 Then
            X = 0
            Y = Y + 2
        Else
            X = X + 2
        End If
        
        arraylength = arraylength - 1
        j = j + 1
    
    Loop Until arraylength = 0

End Sub

' カードの装飾
Private Sub paintCard(ByVal CardValue, ByVal X, ByVal Y)
 
    With Worksheets(MAIN_SHEET).Cells(Y, X)
        
        .Value = CardValue
        .ColumnWidth = CARD_HEIGHT
        .RowHeight = CARD_WIDTH
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = xlVertical
        .Font.Bold = True
        .Font.ColorIndex = CARD_COLOR_RED
        .Interior.ColorIndex = CARD_COLOR_RED

    End With

End Sub

まとめ

いかがでしょうか？

Excel Vba があれば簡単に作れますでのよければぜひ作ってみてください！

※ 作成した Excel 「神経衰弱」は下記からダウンロードできます。よければぜひ遊んでみてください！