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

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日: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を用意しました。


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



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

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


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

エクセル関連で「いいね」の多かったツイート|エクセル雑感(2021-05-17)
キーボード操作だけで非表示列を表示|エクセル雑感(2021-05-11)
変数を考えることはロジックを考える事|エクセル雑感(2021-04-11)
RangeオブジェクトのFor EachとAreasについて|VBA技術解説(2021-04-08)
PropertyのSetはLetでも良い|VBA技術解説(2021-03-31)
エクセル麻雀ミニゲーム|VBAサンプル集(2021-03-09)
VBA100本ノック 100本目:WEBから100本ノックのリストを取得|VBA練習問題(2021-03-03)
VBA100本ノック 魔球編:2桁の最小公倍数|VBA練習問題(2021-02-02)
Select Caseでの短絡評価(ショートサーキット)の使い方|VBA技術解説(2021-01-03)
VBA100本ノック 迷宮編:巡回セル問題|VBA練習問題(2020-12-31)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.Excelショートカットキー一覧|Excelリファレンス
3.変数宣言のDimとデータ型|VBA入門
4.RangeとCellsの使い方|VBA入門
5.マクロって何?VBAって何?|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
9.セルに文字を入れるとは(Range,Value)|VBA入門
10.とにかく書いてみよう(Sub,End Sub)|VBA入門




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


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



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