VBA で数独

数独の解法　

Excel VBA マクロを使って 9×9 マス、16×16 マス、 25×25 マスの数独の解答方法の一例を紹介します。

図1.

図1．のように左上端の開始マスは a1 ～ h8 の範囲内に位置するように作成し、範囲を格子か外枠（図1 右）あるいは外枠太罫線で囲む必要があります。

9×9 マスの場合 ( 図1．左）を例にして解法の概略を示します。空白マスには最初 abcdefghi の文字列が入ります。a は 1 に b は 2 に相当します。絶対入らない数字（ ab… の文字）を消去してアルファベット１文字になれば数字に変えます。１～ 27 にグループ分けし、１～9 は左からそれぞれの列、10～18 は上からそれぞれの行、19～27 は各ブロックの範囲になります。図で Grp(5) は g3～g11、Grp(14) は c7～k7、Grp(24) は i6～k8 のセル範囲です。Grp(0) は c3～k11 のマス全部としています。指定したセルが列、行、ブロックどのグループに属するかをユーザー関数で求めます。図で e8 セルを変数 c に代入すると cG(c), rG(c), bG(c) はそれぞれ 3, 15, 22 を返します。

各グループごとに例えば c の文字が含まれるマス（３が入る可能性のあるマス）の個数をワークシートの COUNTIF 関数で数えます。COUNTIF(範囲, 検索条件) の書式で使い、WorksheetFunction.CountIf(Grp(10), "*c*") が 2 であれば c3～k3 セル範囲中に３の入る可能性のあるセルが２つだけになります。これが 1 であればマスの数値が確定します ( i )。

図2．9×9 マスの例題

5 6
3 4 7 8
1 9
2
8
8 3 7 5
7 4 8
2 9 1
1 4 5 3

① 列あるいは行で 2 ヶ所にしか入らないマスが同じブロック内にあればそのブロック内のほかのマスには当該文字が入らないことになります ( ! )。また、１つのブロック内に２ヶ所しか入らなくそれらのマスが同じ列（または行）にある場合はその列（または行）には当該マス以外にはその文字は入り得ないことになります ( ! )。

② c および e が入るマスが２ヶ所しかなくそれらが同一のマスである場合はそれらのセルの値は『 ce 』に確定することができます ( * )。さらに、c, e, f などの３文字が入るマスが３ヶ所しかなくそれらが３つとも同じマスならば『 cef 』、『 ef 』などにすることができます ( ^ )。

ここでは①のケースで最大２マス、②では最大３マスの参照で作成しています。これ以上のマス参照をしないと解けない難問や、誤記入など不可能な問題では Give UP します。改良版　 Slitherlink

解答済みのセルは斜体で示されます。同じ問題で再度使うときはこの部分が消去されます。解答後、iiii!!!!!^iiiiii-3.97　などのメッセージが表示されます。これは上述の方法でマスの値確定に成功したケースの履歴と所要時間（＋1 秒）を示すものです。

図３．16×16 マスの例

2 9 8 3
8 5 2 11
16 1 7 4 3 5
11 6 4 13 12 7
2 1 7 16
12 8 15 13 11 10 4 7
7 9 10 5 13 12
14 4 3 1 15 5
11 15 1 3 14 9
16 13 7 11 5 2
1 3 4 10 12 8 15 16
7 16 15 5
2 3 15 7 11 5
7 12 16 8 2 1
9 10 16 13
14 12 9 1



Dim c0 As Range, Mas, sM, success As Boolean, Grp() As Range
Sub sudoku()                                                   '---[ 数独  Ver 5.1.1 ]---
    Call SelSt(w):  Set c0 = Range(w)
        For i = 1 To 25:       If c0.Cells(i + 1, 1).Borders(7).LineStyle <> 1 Then Exit For
        Next:  Mas = i:        If Mas = 16 Or Mas = 25 Then Else Mas = 9     ' 開始セル設定(注）xlEdgeLeft=7
ReDim Grp(Mas * 3), nG(1 To Mas, 1 To Mas * 3)
       Set Grp(0) = Range(c0, c0.Cells(Mas, Mas)):    sM = Sqr(Mas)
   If WorksheetFunction.CountIf(Grp(0), ">0") = 0 Then Grp(0).Select: MsgBox "Range missing":  End
 For i = 1 To Mas:   Set Grp(i) = Grp(0).Columns(i).Cells:     Set Grp(Mas + i) = Grp(0).Rows(i).Cells:
      Set Grp(Mas * 2 + i) = SetB(i)
 Next:                                Call Init(c)
     With Grp(0): .HorizontalAlignment = xlCenter: .ColumnWidth = 3.4: .RowHeight = 22.6: .Borders.Weight = 2
     End With:          For i = 2 * Mas + 1 To 3 * Mas: Grp(i).BorderAround Weight:=xlThick: Next
   a = MsgBox(Mas & "×" & Mas & " マスです。" & "Start?", vbYesNo): If a = vbNo Then End
   s = Timer: w = "": For i = 1 To Mas: w = w & Chr(96 + i): Next                    'abcdefghi の 文字列設定
 Set myRange = Grp(0).SpecialCells(4)                                                '(注)xlCellTypeBlanks =4
         With myRange:  '.Font.Size = 11: .Font.Color = vbBlue: .Value = w
                         .Font.Size = 1: .Font.Color = vbWhite: .Value = w
         End With
     For Each c In Grp(0):       If IsNumeric(c.Value) Then Call DelUn(c, w)          '数値セルより文字列消去
     Next
myLoop:
    Do While WorksheetFunction.CountIf(Grp(0), "?") > 0
       For Each c In myRange                                                      'アルファベット１文字の場合
         If c.Value Like "[a-z]" Then w = c.Value: c.Value = Asc(c.Value) - 96: Call DelUn(c, w)
       Next
    Loop:  If WorksheetFunction.CountIf(Grp(0), ">0") = Mas ^ 2 Then ok = True: GoTo Fin        '=== 完了処理
  For ch = 1 To Mas: For Gr = 1 To Mas * 3           '=== 各グループGrに含まれる文字chの数を nG(ch,Gr) に代入
        w = Chr(96 + ch): nG(ch, Gr) = WorksheetFunction.CountIf(Grp(Gr), "*" & w & "*")
  Next: Next:       Lenadv = Len(adv)
   For ch = 1 To Mas:  For Gr = 1 To Mas * 3
    If nG(ch, Gr) = 1 Then                                      '=====================1ヶ所しかない場合 ( i )
        w = Chr(96 + ch):     For Each c In Grp(Gr)
                                   If InStr(c.Value, w) Then c.Value = ch: Call DelUn(c, w): adv = adv & "i"
                              Next
    End If
   Next: Next:                                                       If Len(adv) > Lenadv Then GoTo myLoop
    For ch = 1 To Mas:      For Gr = 1 To Mas * 3
      If nG(ch, Gr) = 2 Then                                   '========================== ２ヶ所の場合 ( ! )
        w = Chr(96 + ch):             Call GetEx(w, Gr, Ex)
          For i = 1 To Mas * 3
            If i <> Gr And Union(Ex, Grp(i)).Cells.Count = Mas Then Call DelC(w, Grp(i), Ex)
         Next
       End If:                        If success = True Then success = False: adv = adv & "!": GoTo myLoop
   Next: Next
  For Gr = 1 To Mas * 3: For ch = 1 To Mas - 1: For ch2 = ch + 1 To Mas
    If nG(ch, Gr) = 2 And nG(ch2, Gr) = 2 Then                 '================ a,b 共に同一の２ヶ所か ( * )
        w = Chr(96 + ch) & Chr(96 + ch2):         Call GetEx(w, Gr, Ex)
           If Ex.Cells.Count = 2 Then
                For Each c In Ex
                   If Len(c.Value) > 2 Then c.Value = w: success = True
                Next
            End If:      End If:      If success = True Then success = False: adv = adv & "*": GoTo myLoop
   Next: Next: Next
 For Gr = 1 To Mas * 3:    For ch = 1 To Mas - 2:    For ch2 = ch + 1 To Mas - 1
           For ch3 = ch2 + 1 To Mas
       n = nG(ch, Gr): n2 = nG(ch2, Gr): n3 = nG(ch3, Gr)
  If (n = 2 Or n = 3) And (n2 = 2 Or n2 = 3) And (n3 = 2 Or n3 = 3) Then '=== a,b,c 共に同一の３ヶ所か  ( ^ )
      st = Chr(96 + ch) & Chr(96 + ch2) & Chr(96 + ch3):   Call GetEx(st, Gr, Ex)
        If Ex.Cells.Count = 3 Then
         w = "": For Each c In Ex: w = w & c.Value: Next
           w = Replace(w, Chr(96 + ch), "")
           w = Replace(w, Chr(96 + ch2), ""): w = Replace(w, Chr(96 + ch3), "")
           If Len(w) > 0 Then
               For i = 1 To Mas: w = Chr(96 + i)
                  If InStr(st, w) Then Else Ex.Replace what:=w, replacement:=""
               Next:                                                         adv = adv & "^": GoTo myLoop
            End If
        End If:    End If:  Next:  Next:  Next:  Next
Fin:    With myRange.Cells.Font: .Color = vbBlue: .Size = 11: .Italic = True      '=================最終処理
        End With:   If ok = True Then MsgBox "Completed" & vbCr & vbCr & adv & Round(s - Timer, 2) - 1: End
        MsgBox "Give UP": Call Init(c): End
End Sub
Function SetB(i)                                                                     ' ブロックのグループ定義
       j = Int((i - 1) / sM): k = i Mod sM: If k = 0 Then k = sM
         y = sM * j + 1: x = sM * (k - 1) + 1
     Set SetB = Range(c0.Cells(y, x), c0.Cells(y + sM - 1, x + sM - 1))
End Function
Function cG(c)                                                                          'セルの列グループ取得
       cG = c.Column - c0.Column + 1
End Function
Function rG(c)                                                                          'セルの行グループ取得
       rG = c.Row - c0.Row + Mas + 1
End Function
Function bG(c)                                                                    'セルのブロックグループ取得
       bG = Int((c.Column - c0.Column) / sM) + 1 + Mas * 2 + Int((c.Row - c0.Row) / sM) * sM
End Function
Sub SelSt(w)                                          '問題範囲検索 (注）xlEdgeLeft=7, xlEdgeTop=8, xlSolid=1
For i = 1 To 8: For j = 1 To 8
  If Cells(j, i).Borders(7).LineStyle = 1 And Cells(j, i).Borders(8).LineStyle = 1 _
   Then w = Cells(j, i).Address: Exit Sub                                                  ' 開始セル番地取得
 Next: Next
Retry:        w = InputBox("開始セルをInput  例  g12" & vbCr & " 無罫線では9×9のみ、" & _
               "中止はキャンセル", "☆開始セルが特定できません"): If w = "" Then End
         If w Like "[a-zA-Z][1-9][0-9]" Or w Like "[a-zA-Z][1-9]" Then Exit Sub Else GoTo Retry
End Sub
Sub GetEx(w, Gr, Ex)
 Dim cel(1 To 9) As Range, wd(1 To 3) As String
    wd(1) = Left(w, 1): wd(2) = Mid(w, 2, 1): wd(3) = Mid(w, 3, 1): n = 0
          For Each c In Grp(Gr):   For i = 1 To 3
             If wd(i) = "" Then Else If InStr(c.Value, wd(i)) Then n = n + 1: Set cel(n) = c
           Next: Next:         Set Ex = cel(1)
    For i = 1 To 9:          If cel(i) Is Nothing Then Else Set Ex = Union(Ex, cel(i))
    Next
End Sub
Sub DelUn(c, w)                         '数値セルより文字列消去
      Union(Grp(cG(c)), Grp(rG(c)), Grp(bG(c))).Replace what:=Chr(96 + c.Value), replacement:=""
End Sub
Sub Init(c)
   For Each c In Grp(0): With c.Font
        If .Color = vbWhite Or .Color = vbBlue Or .Italic = True Then c.Value = ""
           .Color = 0: .Bold = False: .Italic = False: If c.Value <> "" Then .Bold = True
   End With:   Next
End Sub
Sub DelC(w, u, Ex)
  If WorksheetFunction.CountIf(u, "*" & w & "*") = 2 Then Exit Sub
 w1 = Ex.Address
    For Each c In u: If InStr(w1, c.Address) Then Else c.Value = Replace(c.Value, w, "")
Next:                 success = True
End Sub

余録

図4．

例題の場合、図4．までは比較的簡単に求まります。以後、視覚的には図4．から図中３つの * には 1, 3, 5 以外は入らないことに着目すれば解決します。

VBA 記述では、d2 ～ d10 の範囲に 1、3、5 が入る可能性のあるセル（アルファベット表示では a、c、e の文字が存在するセル）が何れも 2 ヶ所あるいは 3 ヶ所であって、しかも、それらが３つの同じセルである場合に成立します。

図中３つの * の範囲は Union(Range("D5"), Range("D6"), Range("D8")) で表示できます。中級以上の数独を解くカギはこのセル集団の発見であるように思います。VBA では変数名 Ex （特別の意味）を使ってこの集団を表しています。因みに、図4．の例でもし３つの * （ Ex ）が同じブロック内にあれば ( If Union(Range("B5:D7"), Ex).Cells.Count = 9 Then ) そのブロックの他のセルには 1, 3, 5 が入り得ないことになりますが、ここまで深く配慮することはしていません。

関連ページ　macro 実行とイミディエイト、　マクロ作成のヒント

このサイトで扱った項目

<a href="./frame0.html">Contents</a>

					2		9	8		3
		8			5					2			11
	16		1			7			4			3		5
		11		6			4	13			12		7
			2		1					7		16
12	8			15		13			11		10			4	7
		7			9		10	5		13			12
14			4			3			1			15			5
11			15			1			3			14			9
		16			13		7	11		5			2
1	3			4		10			12		8			15	16
			7		16					15		5
		2		3			15	7			11		5
	7		12			16			8			2		1
		9			10					16			13
					14		12	9		1

					2		9	8		3
		8			5					2			11
	16		1			7			4			3		5
		11		6			4	13			12		7
			2		1					7		16
12	8			15		13			11		10			4	7
		7			9		10	5		13			12
14			4			3			1			15			5
11			15			1			3			14			9
		16			13		7	11		5			2
1	3			4		10			12		8			15	16
			7		16					15		5
		2		3			15	7			11		5
	7		12			16			8			2		1
		9			10					16			13
					14		12	9		1

					2		9	8		3
		8			5					2			11
	16		1			7			4			3		5
		11		6			4	13			12		7
			2		1					7		16
12	8			15		13			11		10			4	7
		7			9		10	5		13			12
14			4			3			1			15			5
11			15			1			3			14			9
		16			13		7	11		5			2
1	3			4		10			12		8			15	16
			7		16					15		5
		2		3			15	7			11		5
	7		12			16			8			2		1
		9			10					16			13
					14		12	9		1