エクセル麻雀ミニゲーム
マクロVBAを使った麻雀ミニゲームです。
クリックで牌を選択し、再度クリックすると選択が解除されます。
13枚選択時に聴牌判定をしていますので、聴牌出来ない選択ははじかれます。
枚数の下に以下のメッセージを表示しています。
・不聴牌：13枚選択時に聴牌していない。13枚目の選択はキャンセルされます。
・和了：14枚選択時に和了している。
・不和了：14枚選択時に和了していない。14枚目の選択はキャンセルされます。
和了出来ない配牌もあるので、その場合は「配牌」し直してください。
30枚は、麻雀で配牌13枚+自摸17枚に相当します。
つまり門前で自摸あがりを目指すことになります。
やってみると分かりますが、結構あがれない場合があります。
したがって、実際の麻雀でも簡単には自摸あがり出来ないということですね(笑)
30枚は、麻雀で配牌13枚+自摸17枚に相当します。
つまり門前で自摸あがりを目指すことになります。
やってみると分かりますが、結構あがれない場合があります。
したがって、実際の麻雀でも簡単には自摸あがり出来ないということですね(笑)
あがり役の判定はしていません。
ただし、七対子（チートイツ）と国士無双は和了の形が特殊なので、別途判定しています。
エクセル麻雀ミニゲームの動作
「中」のフォントが少しおかしくなりますが、これは「中」だけが特殊な作られ方をしていることに起因しているようです。
エクセル麻雀ミニゲームの全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と選択して、他で面子揃えると聴牌・和了になってしまいます。
これに対処するには、別途判定を入れる必要がありそうなので、今後の検討課題としました。
例えば、下図のように、
筒子の11224455と選択して、他で面子揃えると聴牌・和了になってしまいます。
エクセル麻雀ミニゲームのダウンロード
同じテーマ「マクロVBAサンプル集」の記事
数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1
ナンバーリンク(パズル)を解くVBAに挑戦№1
ナンバーリンクを解くVBAのパフォーマンス改善№1
オセロを作りながらマクロVBAを学ぼう
他ブックへのリンクエラーを探し解除
Excelシートの複雑な計算式を解析するVBA
Excel将棋：マクロVBAの学習用(№1)
Excel囲碁：万波奈穂先生に捧ぐ
Excel囲碁：再起動後も続けて打てるように改造
エクセルVBAで15パズルを作ってみた
エクセル麻雀ミニゲーム
新着記事NEW ・・・新着記事一覧を見る
ブール型（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)
累計を求める数式あれこれ｜エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE｜エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。｜エクセル雑感(2023-12-28)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門
- ホーム
- マクロVBA応用編
- マクロVBAサンプル集
- エクセル麻雀ミニゲーム
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。