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

マクロVBAを使った麻雀ミニゲームです。「配牌」で30枚の牌がランダムに表示されます。クリックで牌を選択し、再度クリックすると選択が解除されます。和了（ホーラ、あがり）することを目指すゲームです。13枚選択時に聴牌判定をしていますので、聴牌出来ない選択ははじかれます。

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

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) = ""

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 DoLoop 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 Thens = 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

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

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。 掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。 本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。 This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.