これは
いわゆる四川省、二角取りをExcelマクロで作ってみたものです
まだ作りかけだけど、基本的な動きは出来た気がするので投稿します
解くのが大変であまりテストできていないので
おかしなところがあったら教えてもらえるとうれしいです
（あと、初めから詰んでいる問題を見極める上手いやり方も・・・）
参考にした記事
https://qiita.com/nagtkk/items/ba720840328185e2cb91
https://qiita.com/masaoki/items/3488320842a9c3f9fc4e
http://www.asahi-net.or.jp/~ax2s-kmtn/ref/unicode/u1f000.html
https://qiita.com/jinoji/items/23a91436b86ffa136dda
コード
Sheet1.cls
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