四川省 for Excel

Option Explicit
Const 行数 = 8, 列数 = 17
Dim 経路 As Range
Dim 外周 As Range
Dim 盤上 As Range
Dim 状況 As Range
Dim 選択中 As Range
Dim 開始 As Single
Dim 通知 As WshShell
Dim 牌山 As Dictionary
Enum 柄
    東 = 0
    伏 = 43
End Enum

Private Sub 変数割当()
    Set 外周 = Me.Cells.Resize(行数 + 2, 列数 + 2).Offset(1, 1)
    Set 盤上 = Me.Cells.Resize(行数, 列数).Offset(2, 2)
    Set 状況 = Me.Cells.Resize(1, 1)
    Set 通知 = CreateObject("WScript.Shell")
    Set 牌山 = CreateObject("Scripting.Dictionary")
End Sub

Sub 初期処理()
    Me.Unprotect
    変数割当
    ActiveWindow.DisplayGridlines = False
    Me.Cells.ClearFormats
    Me.Cells.Clear
    With 外周
        .Font.Size = 20
        .Interior.Color = rgbWhite
        .Font.Color = rgbWhite
        .BorderAround xlContinuous
        .HorizontalAlignment = xlVAlignCenter
        .VerticalAlignment = xlHAlignCenter
        .Value = 牌()
        .Columns.AutoFit
        .Rows.AutoFit
        .Value = ""
    End With
    With 盤上
        .Value = 牌()
        .Interior.Color = rgbWhite
        .Font.Color = rgbBlack
        Dim c As Range, p
        For Each c In .Cells
            p = 牌(Int(牌山.Count / 4))
            c.Value = p
            牌山.Add 牌山.Count, p
        Next
        For Each c In .Cells
            p = 牌()
            c.Value = p
        Next
        For Each c In .Cells
            p = 引牌(牌山)
            c.Value = p
        Next
    End With
    状況更新
    開始 = Timer
    Me.Protect
End Sub

Private Property Get 残対子数()
    If 盤上 Is Nothing Then 変数割当
    残対子数 = WorksheetFunction.CountA(盤上) / 2
End Property

Private Sub 状況更新()
    Me.Unprotect
    状況.Value = 残対子数 & " Pairs Left"
    Me.Protect
End Sub

Private Function 引牌(dic As Dictionary)
    Dim k
    k = dic.Keys(WorksheetFunction.RandBetween(0, dic.Count - 1))
    引牌 = dic(k)
    dic.Remove k
End Function

Private Function 牌(Optional c As 柄 = 伏)
        If c < 東 Or c > 伏 Then c = 伏
         c = c + 61440
         牌 = ChrW(&HD800 + Int(c / &H400)) & ChrW(&HDC00 + CInt(c And &H3FF))
End Function

Private Function 経路取得(p1 As Range, p2 As Range) As Range
    If 外周 Is Nothing Then 変数割当
    If p1 Is Nothing Or p2 Is Nothing Then Exit Function
    If Intersect(p1, 外周) Is Nothing Or Intersect(p2, 外周) Is Nothing Then Exit Function

    Dim rt As Range, cnt As Long
    Dim ec As Range, r As Range, c1 As Range, c2 As Range
    Set ec = Intersect(外周, Range(p1, p2).EntireColumn)
    For Each r In ec.Rows: DoEvents
        Set c1 = Range(p1, Cells(r.Row, p1.Column))
        Set c2 = Range(p2, Cells(r.Row, p2.Column))
        Set rt = Union(c1, r, c2)
        If WorksheetFunction.CountA(rt) = 2 Then
            If cnt = 0 Or rt.Count < cnt Then
                cnt = rt.Count
                Set 経路取得 = rt
            End If
        End If
    Next

    Dim er As Range, c As Range, r1 As Range, r2 As Range
    Set er = Intersect(外周, Range(p1, p2).EntireRow)
    For Each c In er.Columns: DoEvents
        Set r1 = Range(p1, Cells(p1.Row, c.Column))
        Set r2 = Range(p2, Cells(p2.Row, c.Column))
        Set rt = Union(r1, c, r2)
        If WorksheetFunction.CountA(rt) = 2 Then
            If cnt = 0 Or rt.Count < cnt Then
                cnt = rt.Count
                Set 経路取得 = rt
            End If
        End If
    Next
End Function

Private Function 可否(p1 As Range, p2 As Range) As Boolean
    If Not 同一(p1, p2) Then Exit Function
    Set 経路 = 経路取得(p1, p2)
    可否 = Not 経路 Is Nothing
End Function

Private Function 同一(p1 As Range, p2 As Range)
    If IsEmpty(p1) Or IsEmpty(p2) Then Exit Function
    同一 = p1.Value = p2.Value    'TODO:花牌処理
End Function

Private Function 選択(p1 As Range)
    Me.Unprotect
    Set 選択中 = p1
    選択中.Interior.Color = vbCyan
    Me.Protect
End Function

Private Function 選択解除()
    Me.Unprotect
    If 選択中 Is Nothing Then Exit Function
    選択中.Interior.Color = rgbWhite
    Set 選択中 = Nothing
    Me.Protect
End Function

Private Function 詰み判定(Optional c As Range) As Boolean
    If 盤上 Is Nothing Then 変数割当
    For Each c In 盤上
        If 探索(c) Then Exit Function
    Next
    詰み判定 = True
End Function

Private Function 探索(ByVal Target As Range) As Boolean
    Dim c As Range
    If 盤上 Is Nothing Then 変数割当
    For Each c In 盤上
        If Not Target.Address = c.Address Then 探索 = 可否(Target, c)
        If 探索 Then Exit Function
    Next
End Function

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Me.Unprotect
    Cancel = True
    Dim c As Range
    If 盤上 Is Nothing Then 変数割当

    If Intersect(外周, Target) Is Nothing Then
        If Not 詰み判定(c) Then c.Select
        Exit Sub
    End If

    If Target.Value = "" Then
        選択解除
        Exit Sub
    End If

    For Each c In 盤上
        If Not c.Address = Target.Address Then
            If 同一(Target, c) Then c.Interior.Color = vbYellow
            If 可否(Target, c) Then c.Interior.Color = vbCyan
        End If
    Next
    盤上.Interior.Color = rgbWhite
    Target.Interior.Color = vbCyan
    Me.Protect
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then
        ActiveCell.Select
        Exit Sub
    End If

    If 選択中 Is Nothing Then
        If Target.Value = "" Then Exit Sub
        選択 Target
    Else
        If 可否(選択中, Target) Then
            Me.Unprotect
            With 経路
                .Interior.Color = vbCyan
                .ClearContents
                .Interior.Color = rgbWhite
            End With
            状況更新
            If 残対子数 = 0 Then
                通知.Popup Timer - 開始, 3, "CLEAR"
                初期処理
            ElseIf 詰み判定() Then
                通知.Popup "詰んだかも・・・", 3, "NOT CLEAR"
            End If
            Me.Protect
        Else
            選択解除
            Worksheet_SelectionChange Target
        End If
    End If
End Sub