VBAサンプル集
エクセル麻雀ミニゲーム

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
公開日：2021-03-09　最終更新日：2021-03-09

エクセル麻雀ミニゲーム


マクロ VBA 麻雀ミニゲーム

マクロVBAを使った麻雀ミニゲームです。


「配牌」で30枚の牌がランダムに表示されます。
クリックで牌を選択し、再度クリックすると選択が解除されます。

和了（ホーラ、あがり）することを目指すゲームです。
13枚選択時に聴牌判定をしていますので、聴牌出来ない選択ははじかれます。
枚数の下に以下のメッセージを表示しています。

・聴牌：13枚選択時に聴牌している。
・不聴牌：13枚選択時に聴牌していない。13枚目の選択はキャンセルされます。
・和了：14枚選択時に和了している。
・不和了：14枚選択時に和了していない。14枚目の選択はキャンセルされます。

和了すると、理牌（リーパイ）されて表示されます。
和了出来ない配牌もあるので、その場合は「配牌」し直してください。
30枚は、麻雀で配牌13枚+自摸17枚に相当します。
つまり門前で自摸あがりを目指すことになります。
やってみると分かりますが、結構あがれない場合があります。
したがって、実際の麻雀でも簡単には自摸あがり出来ないということですね(笑)

あがり役の判定はしていません。
ただし、七対子（チートイツ）と国士無双は和了の形が特殊なので、別途判定しています。


ページ最後でダウンロードできるようにしてあります。

エクセル麻雀ミニゲームの動作

マクロ VBA 麻雀ミニゲーム

麻雀牌のフォントはUNICODE文字をそのまま使っています。
「中」のフォントが少しおかしくなりますが、これは「中」だけが特殊な作られ方をしていることに起因しているようです。


エクセル麻雀ミニゲームの全VBAコード

シートモジュール

シート名およびオブジェクト名は任意です。

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Call 選択切替(Target)
End Sub


標準モジュール

Option Explicit

Private Const cns配牌 As String = "B2:G6"
Private Const cns枚数 As String = "I4"
Private Const cns案内 As String = "I5"
Private Const cns和了 As String = "I6"

Private Const cns字牌東 As Long = 126976
Private Const cns字牌中 As Long = 126980
Private Const cns字牌撥 As Long = 126981
Private Const cns字牌白 As Long = 126982
Private Const cns萬子1 As Long = 126983
Private Const cns萬子9 As Long = 126991
Private Const cns索子1 As Long = 126992
Private Const cns索子9 As Long = 127000
Private Const cns筒子1 As Long = 127001
Private Const cns筒子9 As Long = 127009

Private Enum 面子
　　なし = 0
　　対子 = 1
　　刻子 = 2
　　順子 = 4
　　槓子 = 8
　　不聴 = 32
End Enum

Public Sub 配牌()
　　Dim oRng As Range
　　Set oRng = Range(cns配牌)
　　With oRng
　　　　.ClearContents
　　　　.Interior.Color = xlNone
　　　　.Font.Color = vbBlack
　　　　.Font.Size = 48
　　End With
　　Range(cns枚数).Value = ""
　　Range(cns案内) = ""
　　Range(cns和了).Resize(, 14) = ""
　　
　　Randomize
　　
　　Dim rndAry(33) As Long '牌は34種類
　　Dim rng As Range, tCode As Long
　　For Each rng In oRng
　　　　Do
　　　　　　tCode = Int((cns筒子9 - cns字牌東 + 1) * Rnd + cns字牌東)
　　　　　　If rndAry(tCode - cns字牌東) < 3 Then Exit Do
　　　　Loop
　　　　rndAry(tCode - cns字牌東) = rndAry(tCode - cns字牌東) + 1
　　　　rng.Value = WorksheetFunction.Unichar(tCode)
　　　　rng.Value = rng.Value
　　　　Select Case tCode
　　　　　　Case cns字牌中, cns萬子1 To cns萬子9
　　　　　　　　rng.Font.Color = vbRed
　　　　　　Case cns字牌撥, cns索子1 To cns索子9
　　　　　　　　rng.Font.Color = RGB(0, 128, 0)
　　　　　　Case cns筒子1 To cns筒子9
　　　　　　　　rng.Font.Color = RGB(102, 51, 0)
　　　　End Select
　　　　
　　　　Application.Wait [Now()+"0:0:0.1"]
　　Next
　　
　　Range(cns枚数).Select
End Sub

Public Sub 選択切替(ByVal Target As Range)
　　If Intersect(Target.Item(1), Range(cns配牌)) Is Nothing Then Exit Sub
　　If Target.Item(1).Value = "" Then Exit Sub
　　
　　Range(cns和了).Resize(, 14) = ""
　　Range(cns案内).Value = ""
　　
　　If Target.Item(1).Interior.Color = vbYellow Then
　　　　Call cancel選択(Target)
　　　　Range(cns枚数).Select
　　Else
　　　　If Range(cns枚数).Value >= 14 Then Exit Sub
　　　　Target.Item(1).Interior.Color = vbYellow
　　End If
　　
　　Dim ary(1 To 14) As String
　　Dim rng As Range, i As Long
　　For Each rng In Range(cns配牌)
　　　　If rng.Interior.Color = vbYellow Then
　　　　　　i = i + 1
　　　　　　ary(i) = 牌2記号(rng.Value)
　　　　End If
　　Next
　　Range(cns枚数).Value = i
　　
　　Dim col待牌 As Collection
　　Select Case i
　　　　Case 13
　　　　　　Set col待牌 = 聴牌(ary)
　　　　　　If col待牌.Count > 0 Then
　　　　　　　　Range(cns案内).Value = "聴牌"
　　　　　　Else
　　　　　　　　Range(cns案内).Value = "不聴牌"
　　　　　　　　Call cancel選択(Target)
　　　　　　End If
　　　　Case 14
　　　　　　If 和了(ary) Then
　　　　　　　　Range(cns案内).Value = "和了"
　　　　　　　　Call 和了牌
　　　　　　　　MsgBox "ゲームクリア"
　　　　　　Else
　　　　　　　　Range(cns案内).Value = "不和了"
　　　　　　　　Call cancel選択(Target)
　　　　　　End If
　　　　Case Is > 14
　　　　　　Call cancel選択(Target)
　　End Select
　　
　　Range(cns枚数).Select
End Sub

Private Sub cancel選択(ByVal Target As Range)
　　Target.Item(1).Interior.Color = xlNone
　　Range(cns枚数).Value = Range(cns枚数).Value - 1
End Sub

Private Function 和了牌() As String
　　Dim ary(1 To 14) As String, rng As Range, i As Long
　　For Each rng In Range(cns配牌)
　　　　If rng.Interior.Color = vbYellow Then
　　　　　　rng.Copy Destination:=Range(cns和了).Offset(, i)
　　　　　　i = i + 1
　　　　End If
　　Next
　　
　　With Range(cns和了).Resize(, 14)
　　　　.Interior.Color = xlNone
　　　　.Borders.LineStyle = xlNone
　　　　.Sort Key1:=Range(cns和了), Header:=xlNo, Orientation:=xlSortRows
　　End With
End Function

Private Function 聴牌(ByRef aAry) As Collection
　　Dim col待牌 As New Collection
　　Dim i As Long, j As Long, s As String, tAry
　　For i = 1 To 4
　　　　For j = 1 To IIf(i = 4, 7, 9)
　　　　　　tAry = aAry
　　　　　　If UBound(Filter(tAry, tAry(j))) < 3 Then
　　　　　　　　s = Switch(i = 1, "m", i = 2, "p", i = 3, "s", i = 4, "j")
　　　　　　　　ReDim Preserve tAry(UBound(tAry) + 1)
　　　　　　　　tAry(UBound(tAry)) = j & s
　　　　　　　　If 和了(tAry) Then
　　　　　　　　　　col待牌.Add j & s
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Next
　　Set 聴牌 = col待牌
End Function

Private Function 和了(ByRef aAry) As Boolean
　　和了 = False
　　
　　Dim 萬子(1 To 9) As Long
　　Dim 筒子(1 To 9) As Long
　　Dim 索子(1 To 9) As Long
　　Dim 字牌(1 To 9) As Long
　　Dim i As Long, v
　　
　　For Each v In aAry
　　　　i = Val(v)
　　　　Select Case Right(v, 1)
　　　　　　Case "m": 萬子(i) = 萬子(i) + 1
　　　　　　Case "p": 筒子(i) = 筒子(i) + 1
　　　　　　Case "s": 索子(i) = 索子(i) + 1
　　　　　　Case "j": 字牌(i) = 字牌(i) + 1
　　　　End Select
　　Next
　　
　　Dim 萬子面子: 萬子面子 = is面子(萬子)
　　Dim 筒子面子: 筒子面子 = is面子(筒子)
　　Dim 索子面子: 索子面子 = is面子(索子)
　　Dim 字牌面子: 字牌面子 = is面子(字牌)
　　
　　'国士無双
　　If is国士(萬子, 筒子, 索子, 字牌) Then
　　　　和了 = True
　　　　Exit Function
　　End If
　　　　
　　'不和了
　　If (萬子面子 Or 筒子面子 Or 索子面子 Or 字牌面子) And 面子.不聴 Then
　　　　Exit Function
　　End If
　　
　　If (萬子面子 Or 筒子面子 Or 索子面子 Or 字牌面子) = 面子.対子 Then
　　　　'七対子
　　Else
　　　　'七対子以外で対子が複数存在する場合は不和了
　　　　If (萬子面子 And 面子.対子) + _
　　　　　 (筒子面子 And 面子.対子) + _
　　　　　 (索子面子 And 面子.対子) + _
　　　　　 (字牌面子 And 面子.対子) > 1 Then
　　　　　　Exit Function
　　　　End If
　　End If
　　
　　和了 = True
End Function

Private Function is面子(ByRef aAry) As 面子
　　Dim has対子 As Boolean, has刻子 As Boolean, has順子 As Boolean
　　Dim tAry, i As Long, j As Long, ix As Long, flg順子 As Boolean
　　Dim st As Long, en As Long, sp As Long, s1 As Long, s2 As Long
　　
　　For ix = 1 To 2 '順子判定：1=小→大、2=大→小
　　　　If ix = 1 Then
　　　　　　st = 1: en = 7: sp = 1: s1 = 1: s2 = 2
　　　　Else
　　　　　　st = 9: en = 3: sp = -1: s1 = -1: s2 = -2
　　　　End If
　　　　tAry = aAry
　　　　
　　　　'順子
　　　　Do
　　　　　　flg順子 = False
　　　　　　For i = st To en Step sp
　　　　　　　　If tAry(i) > 0 Then
　　　　　　　　　　If tAry(i + s1) > 0 And tAry(i + s2) > 0 Then
　　　　　　　　　　　　tAry(i) = tAry(i) - 1
　　　　　　　　　　　　tAry(i + s1) = tAry(i + s1) - 1
　　　　　　　　　　　　tAry(i + s2) = tAry(i + s2) - 1
　　　　　　　　　　　　has順子 = True
　　　　　　　　　　　　flg順子 = True
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next
　　　　Loop While flg順子
　　　　
　　　　'刻子
　　　　For i = 1 To 9
　　　　　　If tAry(i) = 3 Then
　　　　　　　　tAry(i) = 0
　　　　　　　　has刻子 = True
　　　　　　End If
　　　　Next
　　　　
　　　　'対子
　　　　For i = 1 To 9
　　　　　　If tAry(i) = 2 Then
　　　　　　　　tAry(i) = 0
　　　　　　　　has対子 = True
　　　　　　End If
　　　　Next
　　　　
　　　　'全ての数値の処理済判定
　　　　If WorksheetFunction.Sum(tAry) = 0 Then
　　　　　　Exit For
　　　　End If
　　　　
　　　　'不聴牌判定&順子判定の向き変更
　　　　If ix = 1 Then
　　　　　　has対子 = False: has刻子 = False: has順子 = False
　　　　Else
　　　　　　is面子 = 面子.不聴
　　　　　　Exit Function
　　　　End If
　　Next
　　
　　'構成要素をビットで返す
　　If has対子 Then is面子 = is面子 Or 面子.対子
　　If has刻子 Then is面子 = is面子 Or 面子.刻子
　　If has順子 Then is面子 = is面子 Or 面子.順子
End Function

Private Function 牌2記号(ByVal aStr As String) As String
　　Dim tCode As Long
　　tCode = WorksheetFunction.Unicode(aStr)
　　Select Case tCode
　　　　Case cns字牌東 To cns字牌白
　　　　　　牌2記号 = tCode - cns字牌東 + 1 & "j"
　　　　Case cns萬子1 To cns萬子9 '萬子
　　　　　　牌2記号 = tCode - cns萬子1 + 1 & "m"
　　　　Case cns索子1 To cns索子9 '索子
　　　　　　牌2記号 = tCode - cns索子1 + 1 & "s"
　　　　Case cns筒子1 To cns筒子9 '筒子
　　　　　　牌2記号 = tCode - cns筒子1 + 1 & "p"
　　End Select
End Function

Private Function is国士(萬子, 筒子, 索子, 字牌) As Boolean
　　is国士 = False
　　Dim i As Long
　　For i = 1 To 9
　　　　If i = 1 Or i = 9 Then
　　　　　　If 萬子(i) = 0 Then Exit Function
　　　　　　If 筒子(i) = 0 Then Exit Function
　　　　　　If 索子(i) = 0 Then Exit Function
　　　　Else
　　　　　　If 萬子(i) > 0 Then Exit Function
　　　　　　If 筒子(i) > 0 Then Exit Function
　　　　　　If 索子(i) > 0 Then Exit Function
　　　　End If
　　Next
　　For i = 1 To 9
　　　　If i = 1 Or i = 7 Then
　　　　　　If 字牌(i) = 0 Then Exit Function
　　　　End If
　　Next
　　is国士 = True
End Function

※アクティブシートでしか遊べないので、Rangeのシート指定は全て省略しています。

聴牌や和了の判定はもっと効率的なやり方がありそうにも思いますが・・・

役の判定は、それぞれの役ごとにロジックを記載しなければならないので今回は実装しませんでした。
タンヤオなら簡単ですが、全ての役を実装するとなると結構大変ですね。
興味にある方はチャレンジしてみてください。


聴牌・和了の判定が正しく出来ないパターン

七対子に関係する判定が少し不足しています。
例えば、下図のように、
筒子の11224455と選択して、他で面子揃えると聴牌・和了になってしまいます。

マクロ VBA 麻雀ミニゲーム

これに対処するには、別途判定を入れる必要がありそうなので、今後の検討課題としました。


エクセル麻雀ミニゲームのダウンロード

zipとxlsmを用意しました。
mahjong.zip　mahjong.xlsm


他のゲーム（数独、オセロ、将棋、囲碁）も含めたダウンロード一覧は以下になります。

エクセルのサンプルダウンロード



同じテーマ「マクロVBAサンプル集」の記事

数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1
ナンバーリンク(パズル)を解くVBAに挑戦№1
ナンバーリンクを解くVBAのパフォーマンス改善№1
オセロを作りながらマクロVBAを学ぼう
他ブックへのリンクエラーを探し解除
Excelシートの複雑な計算式を解析するVBA
Excel将棋：マクロVBAの学習用(№1)
Excel囲碁：万波奈穂先生に捧ぐ
Excel囲碁：再起動後も続けて打てるように改造
エクセルVBAで15パズルを作ってみた
エクセル麻雀ミニゲーム


新着記事NEW ・・・新着記事一覧を見る

TRIMRANGE関数（セル範囲をトリム：端の空白セルを除外）｜エクセル入門(2024-08-30)
正規表現関数（REGEXTEST,REGEXREPLACE,REGEXEXTRACT）｜エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない｜エクセル雑感(2024-04-11)
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.繰り返し処理（For Next)｜VBA入門
3.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.ブック・シートの選択（Select,Activate）｜VBA入門



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ
同じテーマの記事
新着記事
アクセスランク


↑