Dim m As Integer, n As Integer, h As Integer Dim p(8, 8) As Byte, mx(8, 8) As Byte, rlst(8, 8, 8) As Byte 'pは数独を収納する配列 'mxは各セルの候補数字の個数を収納する配列 'rlstは候補数字を収納する配列 Dim cp(8, 8) As Byte '数独収納配列のコピー Dim y(80) As Byte, x(80) As Byte Dim cy(80) As Byte, cx(80) As Byte '座標のコピー Dim sy(80, 20) As Byte, sx(80, 20) As Byte '相補確定を行ったセルの座標sy(i, j)のiはgを表し、j + 1 は時間gにおける該当セル個数を表す Dim a(8, 8) As Integer Dim hintosu As Byte, rn As Byte Dim cn As Integer Dim cmx(80, 8, 8) As Byte Dim crlst(80, 8, 8, 8) As Byte Dim hth(80, 8, 8) As Byte Dim kh(8, 8, 8) As Byte, ckh(80, 8, 8, 8) As Byte Dim hj1 As Single Dim n2 As Integer, n2_1 As Integer, n_1 As Byte 'n*n等の計算を何回もさせないために導入 Dim sc(80) As Byte '相補確定の起きた個数を数えるカウンタ Dim kz As Integer Dim rh(80) As Byte 'ライン排除確定したかどうかを示す配列 Dim sh(80) As Byte '相補確定とそれによる排除をしたかどうかを示す配列 Dim cnt As Integer Private Sub CommandButton1_Click() Rnd (-1) Dim hj As Single hj = Timer Randomize hj CommandButton2_Click n = Cells(2, 2) rn = Int(Sqr(n)) n2 = n * n n_1 = n - 1 n2_1 = n2 - 1 hintosu = Cells(3, 7) kz = 0 Dim sz As Integer sz = 21600 cnt = 0 Do While 1 gzy '偶然要素を付け加えるプロシージャ＝毎回異なる配置にるするためのプロシージャ zys '座標作成プロシージャ Do While 1 hj1 = Timer zlk '全体リスト構造解析プロシージャ y(0) = 0 x(0) = 0 Call sds(0, 0) '数独作成プロシージャ sdc '数独のコピー zlk '全体リスト構造解析プロシージャ mds '問題作成プロシージャ Call nck(hintosu, 1) Call sds(hintosu, 1) '数独作成プロシージャ zlk '全体リスト構造解析プロシージャ mds '問題作成プロシージャ Call nck(hintosu, 2) Call sds(hintosu, 2) '数独作成プロシージャ If cn = 1 Then Exit Do Loop hyouji '問題表示プロシージャ kz = kz + 1 If kz = sz Then Exit Do Loop ' If kensyou(a, n) = 1 Then ' Cells(4, 2) = "すべての数字が網羅されています。" ' Else ' Cells(4, 2) = "一部の数字しか入っていません。" ' End If '全体リスト構造解析表示プロシージャ 正しいことが確認できた際にはこれを外す。 '全体リスト構造解析表示プロシージャを入れておくと処理にかなり時間を要する。 ' hyouji1 Cells(6, 12) = "数独作成にかかった平均の時間は" Cells(7, 12) = (Timer - hj) / sz Cells(8, 12) = "秒です。" Range("A1").Select End Sub Sub gzy() Dim s As Byte s = Int(Rnd * 10) If s = 0 Then m = 47 If s = 1 Then m = 29 If s = 2 Then m = 52 If s = 3 Then m = 11 If s = 4 Then m = 31 If s = 5 Then m = 43 If s = 6 Then m = 23 If s = 7 Then m = 7 If s = 8 Then m = 13 If s = 9 Then m = 19 h = Int(Rnd * 81) End Sub Sub mds() Dim i As Byte, u As Byte For i = 0 To hintosu - 1 y(i) = cy(i) x(i) = cx(i) Next For i = 0 To hintosu - 1 p(cy(i), cx(i)) = cp(cy(i), cx(i)) u = klk(i) Next End Sub Sub sdc() Dim i As Integer For i = 0 To n2_1 cp(cy(i), cx(i)) = p(cy(i), cx(i)) Next End Sub Sub zlk() '全体リスト構造解析プロシージャ Dim i As Integer, j As Integer, k As Integer, l As Integer cn = 0 For i = 0 To n_1 For j = 0 To n_1 mx(i, j) = n_1 p(i, j) = 0 For k = 0 To n_1 rlst(i, j, k) = k + 1 kh(i, j, k) = 1 '1は白、0は色あり、すなわち1であればセルにk+1が入力可で、0であれば不可 Next Next Next For i = 0 To n2_1 For j = 0 To n_1 For k = 0 To n_1 hth(i, j, k) = 0 Next Next Next End Sub Sub zys() '座標作成プロシージャ Dim i As Byte Dim s As Byte, t As Byte For i = 0 To n2_1 s = Int(i / n) t = i Mod n a(s, t) = (h + i * m) Mod (n2) y(a(s, t)) = s x(a(s, t)) = t cy(a(s, t)) = s cx(a(s, t)) = t Next End Sub Sub sds(g As Byte, mok As Byte) '数独作成プロシージャ If mok = 1 Then If mx(y(g), x(g)) > 0 Then Exit Sub '確定法で問題を解かせるための命令文 'リストは１個しかない場合のみに以降を続ける。 'リストが２個以上ある場合には強制的に前に戻させる。 '試行錯誤はさせないので、g = hintosu まで戻り、 '更に、CommandButton1_ClickのDo文に戻り、 '次の問題を作るようになっている。 '以下同じことを繰り返せば、確定法で解ける問題が必然的に出来る！ '確定法で解く＝試行錯誤をしないので、復元に関する規定は一切不要になるために、 '復元に関する命令文はすべて注釈文にしてある。 If mok = 0 Then If cn = 1 Then Exit Sub If mok = 2 Then If cn = 2 Then Exit Sub Dim i As Byte, ii As Byte, iii As Byte, u As Byte ii = Int(Rnd * mx(y(g), x(g))) For i = 0 To mx(y(g), x(g)) iii = (i + ii) Mod (mx(y(g), x(g)) + 1) p(y(g), x(g)) = rlst(y(g), x(g), iii) u = klk(g) '局所リスト解析プロシージャ If u = 1 Then If g + 1 < n2 Then u = nck(g + 1, mok) If u = 1 Then Call sds(g + 1, mok) End If ' If rh(g + 1) = 1 Then ' mx(y(g + 1), x(g + 1)) = cmx(g + 1, y(g + 1), x(g + 1)) ' For j = 0 To n_1 ' rlst(y(g + 1), x(g + 1), j) = crlst(g + 1, y(g + 1), x(g + 1), j) ' Next ' For j = 0 To n_1 ' kh(y(g + 1), x(g + 1), j) = ckh(g + 1, y(g + 1), x(g + 1), j) ' Next ' End If ' If mok = 1 Then ' If sh(g + 1) = 1 Then ' For j = 0 To sc(g + 1) - 1 ' If hth(g + 1, sy(g + 1, j), sx(g + 1, j)) = 1 Then ' mx(sy(g + 1, j), sx(g + 1, j)) = cmx(g + 1, sy(g + 1, j), sx(g + 1, j)) ' For k = 0 To n_1 ' rlst(sy(g + 1, j), sx(g + 1, j), k) = crlst(g + 1, sy(g + 1, j), sx(g + 1, j), k) ' Next ' For k = 0 To n_1 ' kh(sy(g + 1, j), sx(g + 1, j), k) = ckh(g + 1, sy(g + 1, j), sx(g + 1, j), k) ' Next ' End If ' Next ' End If ' End If If mok = 0 Then If cn = 1 Then Exit Sub If mok = 2 Then If cn = 2 Then Exit Sub Else cn = cn + 1 If mok = 0 Then If cn = 1 Then Exit Sub If mok = 2 Then If cn = 2 Then Exit Sub End If End If hukugen (g) If mok = 0 Then If cn = 1 Then Exit Sub If mok = 2 Then If cn = 2 Then Exit Sub Next p(y(g), x(g)) = 0 End Sub Function rhk(g As Byte) 'ライン排除確定解析＋相補確定解析プロシージャ Dim i As Byte, j As Byte, k As Byte, l As Byte, w As Byte 'wは行･列・ブロックにおける白の個数を数えるカウンタ Dim m As Byte, o As Byte, q As Byte Dim ys(8) As Byte 'y座標を記録する変数 Dim xs(8) As Byte 'x座標を記録する変数 Dim ys1(8) As Byte 'y座標を記録する変数 Dim xs1(8) As Byte 'x座標を記録する変数 Dim hs As Byte Dim ybs As Byte, xbs As Byte Dim ks As Byte, ka As Byte Dim ls As Byte, la As Byte rhk = 1 hs = hintosu sc(g) = 0 ' For i = 0 To n_1 ' For j = 0 To n_1 ' hth(g, i, j) = 0 ' Next ' Next ' rh(g) = 0 ' sh(g) = 0 '以下各数字に対応する行におけるライン排除確定があるかを調べるための手順 For i = 0 To n_1 'i + 1 は入力する数字を示す。 For j = 0 To n_1 'jはy座標（縦座標） w = 0 For k = 0 To n_1 'kはx座標（横座標） If p(j, k) = 0 Then If kh(j, k, i) = 1 Then xs(w) = k w = w + 1 End If End If Next If w = 1 Then '以下ライン排除確定解析 For k = 0 To mx(j, xs(0)) If rlst(j, xs(0), k) = i + 1 Then For l = 0 To n_1 '以下ライン排除確定による破綻解析 If l <> xs(0) And p(j, l) = 0 Then If mx(j, l) = 0 And rlst(j, l, 0) = i + 1 Then ' rh(g) = 0 rhk = 0 Exit Function End If End If Next For l = 0 To n_1 If l <> j And p(l, xs(0)) = 0 Then If mx(l, xs(0)) = 0 And rlst(l, xs(0), 0) = i + 1 Then ' rh(g) = 0 rhk = 0 Exit Function End If End If Next ybs = rn * Int(j / rn) xbs = rn * Int(xs(0) / rn) For l = 0 To n_1 ls = Int(l / rn) la = l Mod rn If ybs + ls <> j And xbs + la <> xs(0) And p(ybs + ls, xbs + la) = 0 Then If mx(ybs + ls, xbs + la) = 0 And rlst(ybs + ls, xbs + la, 0) = i + 1 Then ' rh(g) = 0 rhk = 0 Exit Function End If End If Next '以上ライン排除確定による破綻解析 y(g) = j x(g) = xs(0) ' cmx(g, y(g), x(g)) = mx(y(g), x(g)) ' For l = 0 To n_1 ' crlst(g, y(g), x(g), l) = rlst(y(g), x(g), l) ' Next ' For l = 0 To n_1 ' ckh(g, y(g), x(g), l) = kh(y(g), x(g), l) ' Next rlst(y(g), x(g), 0) = i + 1 rlst(y(g), x(g), 1) = k + 1 mx(y(g), x(g)) = 0 kh(y(g), x(g), i) = 0 ' rh(g) = 1 rhk = 1 Exit Function End If Next End If '以上ライン排除確定解析 If w = 2 Then '以下相補確定解析ための手続き For k = i + 1 To n_1 w = 0 For l = 0 To n_1 If p(j, l) = 0 Then If kh(j, l, k) = 1 Then xs1(w) = l w = w + 1 End If End If Next If w = 2 And xs(0) = xs1(0) And xs(1) = xs1(1) Then For l = 0 To n_1 If l <> xs(0) And l <> xs(1) Then '以下相補確定による破綻解析 If p(j, l) = 0 Then If mx(j, l) = 1 Then If (rlst(j, l, 0) = i + 1 Or rlst(j, l, 1) = i + 1) And (rlst(j, l, 0) = k + 1 Or rlst(j, l, 1) = k + 1) Then rhk = 0 rh(g) = 0 Exit Function End If End If If mx(j, l) = 0 Then If (rlst(j, l, 0) = i + 1 Or rlst(j, l, 1) = i + 1) Or (rlst(j, l, 0) = k + 1 Or rlst(j, l, 1) = k + 1) Then rhk = 0 rh(g) = 0 Exit Function End If End If End If End If Next '以上相補確定による破綻解析 For l = 0 To n_1 '以下相補確定による排除解析 If l <> xs(0) And l <> xs(1) Then If p(j, l) = 0 Then For m = 0 To mx(j, l) If rlst(j, l, m) = i + 1 Then sy(g, sc(g)) = j sx(g, sc(g)) = l ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For o = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o) ' Next ' For o = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o) ' Next rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = i + 1 mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1 kh(sy(g, sc(g)), sx(g, sc(g)), i) = 0 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 Exit For End If If rlst(j, l, m) = k + 1 Then sy(g, sc(g)) = j sx(g, sc(g)) = l ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For o = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o) ' Next ' For o = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o) ' Next rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = k + 1 mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1 kh(sy(g, sc(g)), sx(g, sc(g)), k) = 0 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 Exit For End If Next End If End If Next '以上相補確定による解除解析 If hth(g, j, xs(0)) = 0 Then '以下相補確定 sx(g, sc(g)) = xs(0) sy(g, sc(g)) = j ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For l = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l) ' Next ' For l = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l) ' Next mx(sy(g, sc(g)), sx(g, sc(g))) = 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 End If If hth(g, j, xs(1)) = 0 Then sx(g, sc(g)) = xs(1) sy(g, sc(g)) = j ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For l = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l) ' Next ' For l = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l) ' Next mx(sy(g, sc(g)), sx(g, sc(g))) = 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 End If '以上相補確定 ' sh(g) = 1 Exit Function End If Next End If '以上相補確定解析のための手続き '以下3on3確定解析は大変複雑なため独立プロシージャに仕事を依頼 '本来は、相補確定解析から独立プロシージャに仕事を依頼すべきであった。 '理由は二つ。 'すでにライン排除確定解析プロシージャが大きくなりすぎている！ '仕事を他のプロシージャに依頼すると、コードがすっきりして仕組みがわかりやすくなること！ If w = 3 Then rhk = tontx(g, xs, j, i) 'tontxは行についての3on3解析を行うプロシージャ 'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であったことをお忘れなきように！ Exit Function End If '以上行における白いセルのカウント Next Next '以下各数字に対応する列におけるライン排除確定があるかを調べるための手順 For i = 0 To n_1 'i + 1 は入力する数字を示す。 For j = 0 To n_1 'jはy座標（縦座標） w = 0 For k = 0 To n_1 'kはx座標（横座標） If p(k, j) = 0 Then If kh(k, j, i) = 1 Then ys(w) = k w = w + 1 End If End If Next If w = 1 Then For k = 0 To mx(ys(0), j) If rlst(ys(0), j, k) = i + 1 Then For l = 0 To n_1 '以下ライン排除確定による破綻解析 If l <> j And p(ys(0), l) = 0 Then If mx(ys(0), l) = 0 And rlst(ys(0), l, 0) = i + 1 Then rh(g) = 0 rhk = 0 Exit Function End If End If Next For l = 0 To n_1 If l <> ys(0) And p(l, j) = 0 Then If mx(l, j) = 0 And rlst(l, j, 0) = i + 1 Then rh(g) = 0 rhk = 0 Exit Function End If End If Next ybs = rn * Int(ys(0) / rn) xbs = rn * Int(j / rn) For l = 0 To n_1 ls = Int(l / rn) la = l Mod rn If ybs + ls <> ys(0) And xbs + la <> j And p(ybs + ls, xbs + la) = 0 Then If mx(ybs + ls, xbs + la) = 0 And rlst(ybs + ls, xbs + la, 0) = i + 1 Then rh(g) = 0 rhk = 0 Exit Function End If End If Next '以下ライン排除確定による破綻解析 y(g) = ys(0) x(g) = j ' cmx(g, y(g), x(g)) = mx(y(g), x(g)) ' For l = 0 To n_1 ' crlst(g, y(g), x(g), l) = rlst(y(g), x(g), l) ' Next ' For l = 0 To n_1 ' ckh(g, y(g), x(g), l) = kh(y(g), x(g), l) ' Next rlst(y(g), x(g), k) = rlst(y(g), x(g), 0) rlst(y(g), x(g), 0) = i + 1 mx(y(g), x(g)) = 0 kh(y(g), x(g), i) = 0 ' rh(g) = 1 Exit Function End If Next End If If w = 2 Then '以下相補確定解析のための手続き For k = i + 1 To n_1 w = 0 For l = 0 To n_1 If p(l, j) = 0 Then If kh(l, j, k) = 1 Then ys1(w) = l w = w + 1 End If End If Next If w = 2 And ys(0) = ys1(0) And ys(1) = ys1(1) Then For l = 0 To n_1 '以下相補確定破綻解析 If l <> ys(0) And l <> ys(1) Then If p(l, j) = 0 Then If mx(l, j) = 1 Then If (rlst(l, j, 0) = i + 1 Or rlst(l, j, 1) = i + 1) And (rlst(l, j, 0) = k + 1 Or rlst(l, j, 1) = k + 1) Then rhk = 0 rh(g) = 0 Exit Function End If End If If mx(l, j) = 0 Then If (rlst(l, j, 0) = i + 1 Or rlst(l, j, 1) = i + 1) Or (rlst(l, j, 0) = k + 1 Or rlst(l, j, 1) = k + 1) Then rhk = 0 rh(g) = 0 Exit Function End If End If End If End If Next '以上相補確定破綻解析 For l = 0 To n_1 '以下相補確定による排除解析 If l <> ys(0) And l <> ys(1) Then If p(l, j) = 0 Then For m = 0 To mx(l, j) If rlst(l, j, m) = i + 1 Then sy(g, sc(g)) = l sx(g, sc(g)) = j ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For o = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o) ' Next ' For o = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o) ' Next rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = i + 1 mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1 kh(sy(g, sc(g)), sx(g, sc(g)), i) = 0 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 Exit For End If If rlst(l, j, m) = k + 1 Then sy(g, sc(g)) = l sx(g, sc(g)) = j ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For o = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o) ' Next ' For o = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o) ' Next rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = k + 1 mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1 kh(sy(g, sc(g)), sx(g, sc(g)), k) = 0 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 Exit For End If Next End If End If Next '以上相補確定による排除解析 If hth(g, j, ys(0)) = 0 Then '以下相補確定解析 sx(g, sc(g)) = j sy(g, sc(g)) = ys(0) ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For l = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l) ' Next ' For l = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l) ' Next mx(sy(g, sc(g)), sx(g, sc(g))) = 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 End If If hth(g, j, ys(1)) = 0 Then sx(g, sc(g)) = j sy(g, sc(g)) = ys(1) ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For l = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l) ' Next ' For l = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l) ' Next mx(sy(g, sc(g)), sx(g, sc(g))) = 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 End If '以上相補確定 ' sh(g) = 1 Exit Function End If Next End If '以上相補確定解析のための手続き '以下3on3確定解析は大変複雑なため独立プロシージャに仕事を依頼 '本来は、相補確定解析から独立プロシージャに仕事を依頼すべきであった。 '理由は二つ。 'すでにライン排除確定解析プロシージャが大きくなりすぎている！ '仕事を他のプロシージャに依頼すると、コードがすっきりして仕組みがわかりやすくなること！ If w = 3 Then rhk = tonty(g, ys, j, i) 'tontyは列についての3on3解析を行うプロシージャ 'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であったことをお忘れなきように！ Exit Function End If '以上行における白いセルのカウント Next Next '以下各数字に対応するブロックにおけるライン排除確定があるかを調べるための手順 For i = 0 To n_1 'i + 1 は入力する数字を示す。 For j = 0 To n_1 'jはy座標（縦座標） ybs = rn * Int(j / rn) xbs = rn * (j Mod rn) w = 0 For k = 0 To n_1 'kはx座標（横座標） ks = Int(k / rn) ka = k Mod rn If p(ybs + ks, xbs + ka) = 0 Then If kh(ybs + ks, xbs + ka, i) = 1 Then ys(w) = ybs + ks xs(w) = xbs + ka w = w + 1 End If End If Next If w = 1 Then For k = 0 To mx(ys(0), xs(0)) If rlst(ys(0), xs(0), k) = i + 1 Then For l = 0 To n_1 '以下ライン排除確定による破綻解析 If l <> xs(0) And p(ys(0), l) = 0 Then If mx(ys(0), l) = 0 And rlst(ys(0), l, 0) = i + 1 Then rh(g) = 0 rhk = 0 Exit Function End If End If Next For l = 0 To n_1 If l <> ys(0) And p(l, xs(0)) = 0 Then If mx(l, xs(0)) = 0 And rlst(l, xs(0), 0) = i + 1 Then rh(g) = 0 rhk = 0 Exit Function End If End If Next ybs = rn * Int(ys(0) / rn) xbs = rn * Int(xs(0) / rn) For l = 0 To n_1 ls = Int(l / rn) la = l Mod rn If ybs + ls <> ys(0) And xbs + la <> xs(0) And p(ybs + ls, xbs + la) = 0 Then If mx(ybs + ls, xbs + la) = 0 And rlst(ybs + ls, xbs + la, 0) = i + 1 Then rh(g) = 0 rhk = 0 Exit Function End If End If Next '以上ライン排除確定による破綻解析 y(g) = ys(0) x(g) = xs(0) ' cmx(g, y(g), x(g)) = mx(y(g), x(g)) ' For l = 0 To n_1 ' crlst(g, y(g), x(g), l) = rlst(y(g), x(g), l) ' Next ' For l = 0 To n_1 ' ckh(g, y(g), x(g), l) = kh(y(g), x(g), l) ' Next rlst(y(g), x(g), k) = rlst(y(g), x(g), 0) rlst(y(g), x(g), 0) = i + 1 mx(y(g), x(g)) = 0 kh(y(g), x(g), i) = 0 ' rh(g) = 1 Exit Function End If Next End If If w = 2 Then '以下相補確定解析のための手続き For k = i + 1 To n_1 w = 0 For l = 0 To n_1 ls = Int(l / rn) la = l Mod rn If p(ybs + ls, xbs + la) = 0 Then If kh(ybs + ls, xbs + la, k) = 1 Then xs1(w) = xbs + la ys1(w) = ybs + ls w = w + 1 End If End If Next If w = 2 And (xs(0) = xs1(0) And ys(0) = ys1(0)) And (xs(1) = xs1(1) And ys(1) = ys1(1)) Then For l = 0 To n_1 '以下相補確定破綻解析 ls = Int(l / rn) la = l Mod rn If (xbs + la <> xs(0) Or ybs + ls <> ys(0)) And (xbs + la <> xs(1) Or ybs + ls <> ys(1)) Then If p(ybs + ls, xbs + la) = 0 Then If mx(ybs + ls, xbs + la) = 1 Then If (rlst(ybs + ls, xbs + la, 0) = i + 1 Or rlst(ybs + ls, xbs + la, 1) = i + 1) And (rlst(ybs + ls, xbs + la, 0) = k + 1 Or rlst(ybs + ls, xbs + la, 1) = k + 1) Then rhk = 0 rh(g) = 0 Exit Function End If End If If mx(ybs + ls, xbs + la) = 0 Then If (rlst(ybs + ls, xbs + la, 0) = i + 1 Or rlst(ybs + ls, xbs + la, 1) = i + 1) Or (rlst(ybs + ls, xbs + la, 0) = k + 1 Or rlst(ybs + ls, xbs + la, 1) = k + 1) Then rhk = 0 rh(g) = 0 Exit Function End If End If End If End If Next '以上相補確定による破綻解析 For l = 0 To n_1 '以下相補確定による排除解析 ls = Int(l / rn) la = l Mod rn If (xbs + la <> xs(0) Or ybs + ls <> ys(0)) And (xbs + la <> xs(1) Or ybs + ls <> ys(1)) Then If p(ybs + ls, xbs + la) = 0 Then For m = 0 To mx(ybs + ls, xbs + la) If rlst(ybs + ls, xbs + la, m) = i + 1 Then sy(g, sc(g)) = ybs + ls sx(g, sc(g)) = xbs + la ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For o = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o) ' Next ' For o = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o) ' Next rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = i + 1 mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1 kh(sy(g, sc(g)), sx(g, sc(g)), i) = 0 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 Exit For End If If rlst(ybs + ls, xbs + la, m) = k + 1 Then sy(g, sc(g)) = ybs + ls sx(g, sc(g)) = xbs + la ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For o = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), o) = rlst(sy(g, sc(g)), sx(g, sc(g)), o) ' Next ' For o = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), o) = kh(sy(g, sc(g)), sx(g, sc(g)), o) ' Next rlst(sy(g, sc(g)), sx(g, sc(g)), m) = rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) rlst(sy(g, sc(g)), sx(g, sc(g)), mx(sy(g, sc(g)), sx(g, sc(g)))) = k + 1 mx(sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) - 1 kh(sy(g, sc(g)), sx(g, sc(g)), k) = 0 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 Exit For End If Next End If End If Next '以上相補確定による排除解析 If hth(g, ys(0), xs(0)) = 0 Then '以下相補確定 sx(g, sc(g)) = xs(0) sy(g, sc(g)) = ys(0) ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For l = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l) ' Next ' For l = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l) ' Next mx(sy(g, sc(g)), sx(g, sc(g))) = 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 End If If hth(g, ys(1), xs(1)) = 0 Then sx(g, sc(g)) = xs(1) sy(g, sc(g)) = ys(1) ' cmx(g, sy(g, sc(g)), sx(g, sc(g))) = mx(sy(g, sc(g)), sx(g, sc(g))) ' For l = 0 To n_1 ' crlst(g, sy(g, sc(g)), sx(g, sc(g)), l) = rlst(sy(g, sc(g)), sx(g, sc(g)), l) ' Next ' For l = 0 To n_1 ' ckh(g, sy(g, sc(g)), sx(g, sc(g)), l) = kh(sy(g, sc(g)), sx(g, sc(g)), l) ' Next mx(sy(g, sc(g)), sx(g, sc(g))) = 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 0) = i + 1 rlst(sy(g, sc(g)), sx(g, sc(g)), 1) = k + 1 ' hth(g, sy(g, sc(g)), sx(g, sc(g))) = 1 sc(g) = sc(g) + 1 End If '以上相補確定 sh(g) = 1 Exit Function End If Next End If '以上相補確定解析のための手続き '以下3on3確定解析は大変複雑なため独立プロシージャに仕事を依頼 '本来は、相補確定解析から独立プロシージャに仕事を依頼すべきであった。 '理由は二つ。 'すでにライン排除確定解析プロシージャが大きくなりすぎている！ '仕事を他のプロシージャに依頼すると、コードがすっきりして仕組みがわかりやすくなること！ If w = 3 Then rhk = tontb(g, ys, xs, i) 'tontyは列についての3on3解析を行うプロシージャ 'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であったことをお忘れなきように！ Exit Function End If '以上行における白いセルのカウント Next Next End Function Function tontx(g As Byte, xs() As Byte, s As Byte, ny As Byte) '行についての3on3解析を行うFunctionプロシージャ '引数のnyは、内容（naiyou）の略、呼び出し側のライン排除確定プロシージャのiに当たる。 'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であった。 '確定法で解く＝仮定法を使わないので復元規定は最初から記述しない。 Dim i As Byte, j As Byte, k As Byte, l As Byte, m As Byte, o As Byte, w As Byte Dim xs1(8) As Byte 'x座標を記録する変数 Dim xs2(8) As Byte 'x座標を記録する変数 tontx = 1 For i = ny + 1 To n_1 'i + 1 は数独配列p(○, ○)に入れる２番目の内容（１から９の値） 'もっと正確に説明すると、3on3のセルにおけるリストの２番目となる可能性のある値である。 '可能性という言い方をしたのは、以下の条件を満たしてはじめて２番目のリストになるから。 w = 0 For j = 0 To n_1 'jはx座標(横座標） If p(s, j) = 0 Then 's = ys(0) If kh(s, j, i) = 1 Then xs1(w) = j w = w + 1 End If End If Next If w = 3 Then If xs(0) = xs1(0) And xs(1) = xs1(1) And xs(2) = xs1(2) Then For j = 0 To n_1 'j + 1 は3on3セルの３番目のリスト候補 If j <> ny And j <> i Then w = 0 For k = 0 To n_1 'kはx座標(横座標） If p(s, k) = 0 Then 's = ys(0) If kh(s, k, j) = 1 Then xs2(w) = k w = w + 1 End If End If Next If w = 2 Or w = 3 Then If (xs2(0) = xs(0) And xs2(1) = xs(1)) Or (xs2(0) = xs(0) And xs2(2) = xs(2)) Or (xs2(1) = xs(1) And xs2(2) = xs(2)) Then '以降3on3確定による破綻処理 For k = 0 To n_1 If k <> xs(0) And k <> xs(1) And k <> xs(2) Then If p(s, k) = 0 Then If mx(s, k) = 2 Then w = 0 For l = 0 To 2 If rlst(s, k, l) = ny + 1 Or rlst(s, k, l) = i + 1 Or rlst(s, k, l) = j + 1 Then w = w + 1 End If Next If w = 3 Then tontx = 0 Exit Function End If End If If mx(s, k) = 1 Then w = 0 For l = 0 To 1 If rlst(s, k, l) = ny + 1 Or rlst(s, k, l) = i + 1 Or rlst(s, k, l) = j + 1 Then w = w + 1 End If Next If w = 2 Then tontx = 0 Exit Function End If End If If mx(s, k) = 0 Then If rlst(s, k, 0) = ny + 1 Or rlst(s, k, 0) = i + 1 Or rlst(s, k, 0) = j + 1 Then tontx = 0 Exit Function End If End If End If End If Next '3on3確定による破綻処理終了 ' Cells(4 + Int(cnt / 50), 1 + (cnt Mod 50)) = "X" ' cnt = cnt + 1 '以降3on3確定による排除解析 For k = 0 To n_1 If k <> xs(0) And k <> xs(1) And k <> xs(2) Then If p(s, k) = 0 Then For l = 0 To mx(s, k) If ny + 1 = rlst(s, k, l) Then rlst(s, k, l) = rlst(s, k, mx(s, k)) rlst(s, k, mx(s, k)) = ny + 1 kh(s, k, ny) = 0 mx(s, k) = mx(s, k) - 1 Exit For End If Next For l = 0 To mx(s, k) If i + 1 = rlst(s, k, l) Then rlst(s, k, l) = rlst(s, k, mx(s, k)) rlst(s, k, mx(s, k)) = i + 1 kh(s, k, i) = 0 mx(s, k) = mx(s, k) - 1 Exit For End If Next For l = 0 To mx(s, k) If j + 1 = rlst(s, k, l) Then rlst(s, k, l) = rlst(s, k, mx(s, k)) rlst(s, k, mx(s, k)) = j + 1 kh(s, k, j) = 0 mx(s, k) = mx(s, k) - 1 Exit For End If Next End If End If Next '3on3確定による排除解析終了 '以降3on3確定解析 Dim kr(2) As Byte For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(s, xs(0)) If ny + 1 = rlst(s, xs(0), k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(s, xs(0)) If i + 1 = rlst(s, xs(0), k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(s, xs(0)) If j + 1 = rlst(s, xs(0), k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(s, xs(0), 0) = ny + 1 rlst(s, xs(0), 1) = i + 1 rlst(s, xs(0), 2) = j + 1 mx(s, xs(0)) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(s, xs(0), w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(s, xs(0), w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(s, xs(0), w) = j + 1 w = w + 1 End If mx(s, xs(0)) = 1 End If For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(s, xs(1)) If ny + 1 = rlst(s, xs(1), k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(s, xs(1)) If i + 1 = rlst(s, xs(1), k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(s, xs(1)) If j + 1 = rlst(s, xs(1), k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(s, xs(1), 0) = ny + 1 rlst(s, xs(1), 1) = i + 1 rlst(s, xs(1), 2) = j + 1 mx(s, xs(1)) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(s, xs(1), w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(s, xs(1), w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(s, xs(1), w) = j + 1 w = w + 1 End If mx(s, xs(1)) = 1 End If For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(s, xs(2)) If ny + 1 = rlst(s, xs(2), k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(s, xs(2)) If i + 1 = rlst(s, xs(2), k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(s, xs(2)) If j + 1 = rlst(s, xs(2), k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(s, xs(2), 0) = ny + 1 rlst(s, xs(2), 1) = i + 1 rlst(s, xs(2), 2) = j + 1 mx(s, xs(2)) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(s, xs(2), w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(s, xs(2), w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(s, xs(2), w) = j + 1 w = w + 1 End If mx(s, xs(2)) = 1 End If '3on3確定解析終了 Exit For End If End If End If Next End If End If Next End Function Function tonty(g As Byte, ys() As Byte, t As Byte, ny As Byte) '列についての3on3解析を行うFunctionプロシージャ '引数のnyは、内容（naiyou）の略、呼び出し側のライン排除確定プロシージャのiに当たる。 'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であった。 '確定法で解く＝仮定法を使わないので復元規定は最初から記述しない。 Dim i As Byte, j As Byte, k As Byte, l As Byte, m As Byte, o As Byte, w As Byte Dim ys1(8) As Byte 'y座標を記録する変数 Dim ys2(8) As Byte 'y座標を記録する変数 tonty = 1 Dim xs1(8) As Byte 'x座標を記録する変数 Dim xs2(8) As Byte 'x座標を記録する変数 tonty = 1 For i = ny + 1 To n_1 'i + 1 は数独配列p(○, ○)に入れる２番目の内容（１から９の値） 'もっと正確に説明すると、3on3のセルにおけるリストの２番目となる可能性のある値である。 '可能性という言い方をしたのは、以下の条件を満たしてはじめて２番目のリストになるから。 w = 0 For j = 0 To n_1 'jはx座標(横座標） If p(j, t) = 0 Then 's = ys(0) If kh(j, t, i) = 1 Then ys1(w) = j w = w + 1 End If End If Next If w = 3 Then If ys(0) = ys1(0) And ys(1) = ys1(1) And ys(2) = ys1(2) Then For j = 0 To n_1 'j + 1 は3on3セルの３番目のリスト候補 If j <> ny And j <> i Then w = 0 For k = 0 To n_1 'kはx座標(横座標） If p(k, t) = 0 Then 's = ys(0) If kh(k, t, j) = 1 Then ys2(w) = k w = w + 1 End If End If Next If w = 2 Or w = 3 Then If (ys2(0) = ys(0) And ys2(1) = ys(1)) Or (ys2(0) = ys(0) And ys2(2) = ys(2)) Or (ys2(1) = ys(1) And ys2(2) = ys(2)) Then '以降3on3確定による破綻処理 For k = 0 To n_1 If k <> ys(0) And k <> ys(1) And k <> ys(2) Then If p(k, t) = 0 Then If mx(k, t) = 2 Then w = 0 For l = 0 To 2 If rlst(k, t, l) = ny + 1 Or rlst(k, t, l) = i + 1 Or rlst(k, t, l) = j + 1 Then w = w + 1 End If Next If w = 3 Then tonty = 0 Exit Function End If End If If mx(k, t) = 1 Then w = 0 For l = 0 To 1 If rlst(k, t, l) = ny + 1 Or rlst(k, t, l) = i + 1 Or rlst(k, t, l) = j + 1 Then w = w + 1 End If Next If w = 2 Then tonty = 0 Exit Function End If End If If mx(k, t) = 0 Then If rlst(k, t, 0) = ny + 1 Or rlst(k, t, 0) = i + 1 Or rlst(k, t, 0) = j + 1 Then tonty = 0 Exit Function End If End If End If End If Next '3on3確定による破綻処理終了 ' Cells(4 + Int(cnt / 50), 1 + (cnt Mod 50)) = "X" ' cnt = cnt + 1 '以降3on3確定による排除解析 For k = 0 To n_1 If k <> ys(0) And k <> ys(1) And k <> ys(2) Then If p(k, t) = 0 Then For l = 0 To mx(k, t) If ny + 1 = rlst(k, t, l) Then rlst(k, t, l) = rlst(k, t, mx(k, t)) rlst(k, t, mx(k, t)) = ny + 1 kh(k, t, ny) = 0 mx(k, t) = mx(k, t) - 1 Exit For End If Next For l = 0 To mx(k, t) If i + 1 = rlst(k, t, l) Then rlst(k, t, l) = rlst(k, t, mx(k, t)) rlst(k, t, mx(k, t)) = i + 1 kh(k, t, i) = 0 mx(k, t) = mx(k, t) - 1 Exit For End If Next For l = 0 To mx(k, t) If j + 1 = rlst(k, t, l) Then rlst(k, t, l) = rlst(k, t, mx(k, t)) rlst(k, t, mx(k, t)) = j + 1 kh(k, t, j) = 0 mx(k, t) = mx(k, t) - 1 Exit For End If Next End If End If Next '3on3確定による排除解析終了 '以降3on3確定解析 Dim kr(2) As Byte For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(ys(0), t) If ny + 1 = rlst(ys(0), t, k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(0), t) If i + 1 = rlst(ys(0), t, k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(0), t) If j + 1 = rlst(ys(0), t, k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(ys(0), t, 0) = ny + 1 rlst(ys(0), t, 1) = i + 1 rlst(ys(0), t, 2) = j + 1 mx(ys(0), t) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(ys(0), t, w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(ys(0), t, w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(ys(0), t, w) = j + 1 w = w + 1 End If mx(ys(0), t) = 1 End If For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(ys(1), t) If ny + 1 = rlst(ys(1), t, k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(1), t) If i + 1 = rlst(ys(1), t, k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(1), t) If j + 1 = rlst(ys(1), t, k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(ys(1), t, 0) = ny + 1 rlst(ys(1), t, 1) = i + 1 rlst(ys(1), t, 2) = j + 1 mx(ys(1), t) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(ys(1), t, w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(ys(1), t, w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(ys(1), t, w) = j + 1 w = w + 1 End If mx(ys(1), t) = 1 End If For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(ys(2), t) If ny + 1 = rlst(ys(2), t, k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(2), t) If i + 1 = rlst(ys(2), t, k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(2), t) If j + 1 = rlst(ys(2), t, k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(ys(2), t, 0) = ny + 1 rlst(ys(2), t, 1) = i + 1 rlst(ys(2), t, 2) = j + 1 mx(ys(2), t) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(ys(2), t, w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(ys(2), t, w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(ys(2), t, w) = j + 1 w = w + 1 End If mx(ys(2), t) = 1 End If '3on3確定解析終了 Exit For End If End If End If Next End If End If Next End Function Function tontb(g As Byte, ys() As Byte, xs() As Byte, ny As Byte) '行についての3on3解析を行うFunctionプロシージャ '引数のnyは、内容（naiyou）の略、呼び出し側のライン排除確定プロシージャのiに当たる。 'i + 1は、数独配列p(○, ○)に入力する内容（１から９の値）であった。 '確定法で解く＝仮定法を使わないので復元規定は最初から記述しない。 Dim i As Byte, j As Byte, k As Byte, l As Byte, m As Byte, o As Byte, w As Byte Dim xs1(8) As Byte 'x座標を記録する変数 Dim xs2(8) As Byte 'x座標を記録する変数 Dim ys1(8) As Byte 'x座標を記録する変数 Dim ys2(8) As Byte 'x座標を記録する変数 tontb = 1 Dim ybs As Byte, xbs As Byte ybs = rn * Int(ys(0) / rn) xbs = rn * Int(xs(0) / rn) Dim js As Byte, ja As Byte Dim ks As Byte, ka As Byte For i = ny + 1 To n_1 'i + 1 は数独配列p(○, ○)に入れる２番目の内容（１から９の値） 'もっと正確に説明すると、3on3のセルにおけるリストの２番目となる可能性のある値である。 '可能性という言い方をしたのは、以下の条件を満たしてはじめて２番目のリストになるから。 w = 0 For j = 0 To n_1 'jはブロック番号 js = Int(j / rn) ja = j Mod rn If p(ybs + js, xbs + ja) = 0 Then 's = ys(0) If kh(ybs + js, xbs + ja, i) = 1 Then ys1(w) = ybs + js xs1(w) = xbs + ja w = w + 1 End If End If Next If w = 3 Then If (ys(0) = ys1(0) Or xs(0) = xs1(0)) And (ys(1) = ys1(1) Or xs(1) = xs1(1)) And (ys(2) = ys1(2) Or xs(2) = xs1(2)) Then For j = 0 To n_1 'j + 1 は3on3セルの３番目のリスト候補 If j <> ny And j <> i Then w = 0 For k = 0 To n_1 'kはブロック内番号 ks = Int(k / rn) ka = k Mod rn If p(ybs + ks, xbs + ka) = 0 Then 's = ys(0) If kh(ybs + ks, xbs + ka, j) = 1 Then ys2(w) = ybs + ks xs2(w) = xbs + ka w = w + 1 End If End If Next If w = 2 Or w = 3 Then If (((ys2(0) = ys(0)) And (xs2(0) = xs(0))) And (((ys2(1) = ys(1)) And xs2(1) = xs(1)))) Or (((ys2(0) = ys(0)) And (xs2(0) = xs(0))) And (((ys2(2) = ys(2)) And xs2(2) = xs(2)))) Or (((ys2(1) = ys(1)) And (xs2(1) = xs(1))) And (((ys2(2) = ys(2)) And xs2(2) = xs(2)))) Then '以降3on3確定による破綻処理 For k = 0 To n_1 ks = Int(k / rn) ka = k Mod rn If (ybs + ks <> ys(0) Or xbs <> xs(0)) And (ybs + ks <> ys(1) Or xbs <> xs(1)) And (ybs + ks <> ys(2) Or xbs <> xs(2)) Then If p(ybs + ks, xbs + ka) = 0 Then If mx(ybs + ks, xbs + ka) = 2 Then w = 0 For l = 0 To 2 If rlst(ybs + ks, xbs + ka, l) = ny + 1 Or rlst(ybs + ks, xbs + ka, l) = i + 1 Or rlst(ybs + ks, xbs + ka, l) = j + 1 Then w = w + 1 End If Next If w = 3 Then tontb = 0 Exit Function End If End If If mx(ybs + ks, xbs + ka) = 1 Then w = 0 For l = 0 To 1 If rlst(ybs + ks, xbs + ka, l) = ny + 1 Or rlst(ybs + ks, xbs + ka, l) = i + 1 Or rlst(ybs + ks, xbs + ka, l) = j + 1 Then w = w + 1 End If Next If w = 2 Then tontb = 0 Exit Function End If End If If mx(ybs + ks, xbs + ka) = 0 Then If rlst(ybs + ks, xbs + ka, 0) = ny + 1 Or rlst(ybs + ks, xbs + ka, 0) = i + 1 Or rlst(ybs + ks, xbs + ka, 0) = j + 1 Then tontb = 0 Exit Function End If End If End If End If Next '3on3確定による破綻処理終了 ' Cells(4 + Int(cnt / 50), 1 + (cnt Mod 50)) = "X" ' cnt = cnt + 1 '以降3on3確定による排除解析 For k = 0 To n_1 ks = Int(k / rn) ka = k Mod rn If (ybs + ks <> ys(0) Or xbs <> xs(0)) And (ybs + ks <> ys(1) Or xbs <> xs(1)) And (ybs + ks <> ys(2) Or xbs <> xs(2)) Then If p(ybs + ks, xbs + ka) = 0 Then For l = 0 To mx(ybs + ks, xbs + ka) If ny + 1 = rlst(ybs + ks, xbs + ka, l) Then rlst(ybs + ks, xbs + ka, l) = rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) = ny + 1 kh(ybs + ks, xbs + ka, ny) = 0 mx(ybs + ks, xbs + ka) = mx(ybs + ks, xbs + ka) - 1 Exit For End If Next For l = 0 To mx(ybs + ks, xbs + ka) If i + 1 = rlst(ybs + ks, xbs + ka, l) Then rlst(ybs + ks, xbs + ka, l) = rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) = i + 1 kh(ybs + ks, xbs + ka, i) = 0 mx(ybs + ks, xbs + ka) = mx(ybs + ks, xbs + ka) - 1 Exit For End If Next For l = 0 To mx(ybs + ks, xbs + ka) If j + 1 = rlst(ybs + ks, xbs + ka, l) Then rlst(ybs + ks, xbs + ka, l) = rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) rlst(ybs + ks, xbs + ka, mx(ybs + ks, xbs + ka)) = j + 1 kh(ybs + ks, xbs + ka, j) = 0 mx(ybs + ks, xbs + ka) = mx(ybs + ks, xbs + ka) - 1 Exit For End If Next End If End If Next '3on3確定による排除解析終了 '以降3on3確定解析 Dim kr(2) As Byte For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(ys(0), xs(0)) If ny + 1 = rlst(ys(0), xs(0), k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(0), xs(0)) If i + 1 = rlst(ys(0), xs(0), k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(0), xs(0)) If j + 1 = rlst(ys(0), xs(0), k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(ys(0), xs(0), 0) = ny + 1 rlst(ys(0), xs(0), 1) = i + 1 rlst(ys(0), xs(0), 2) = j + 1 mx(ys(0), xs(0)) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(ys(0), xs(0), w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(ys(0), xs(0), w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(ys(0), xs(0), w) = j + 1 w = w + 1 End If mx(ys(0), xs(0)) = 1 End If For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(ys(1), xs(1)) If ny + 1 = rlst(ys(1), xs(1), k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(1), xs(1)) If i + 1 = rlst(ys(1), xs(1), k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(1), xs(1)) If j + 1 = rlst(ys(1), xs(1), k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(ys(1), xs(1), 0) = ny + 1 rlst(ys(1), xs(1), 1) = i + 1 rlst(ys(1), xs(1), 2) = j + 1 mx(ys(1), xs(1)) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(ys(1), xs(1), w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(ys(1), xs(1), w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(ys(1), xs(1), w) = j + 1 w = w + 1 End If mx(ys(1), xs(1)) = 1 End If For k = 0 To 2 kr(k) = 0 Next w = 0 For k = 0 To mx(ys(2), xs(2)) If ny + 1 = rlst(ys(2), xs(2), k) Then kr(0) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(2), xs(2)) If i + 1 = rlst(ys(2), xs(2), k) Then kr(1) = 1 w = w + 1 Exit For End If Next For k = 0 To mx(ys(2), xs(2)) If j + 1 = rlst(ys(2), xs(2), k) Then kr(2) = 1 w = w + 1 Exit For End If Next If w = 3 Then rlst(ys(2), xs(2), 0) = ny + 1 rlst(ys(2), xs(2), 1) = i + 1 rlst(ys(2), xs(2), 2) = j + 1 mx(ys(2), xs(2)) = 2 End If If w = 2 Then w = 0 If kr(0) = 1 Then rlst(ys(2), xs(2), w) = ny + 1 w = w + 1 End If If kr(1) = 1 Then rlst(ys(2), xs(2), w) = i + 1 w = w + 1 End If If kr(2) = 1 Then rlst(ys(2), xs(2), w) = j + 1 w = w + 1 End If mx(ys(2), xs(2)) = 1 End If '3on3確定解析終了 Exit For End If End If End If Next End If End If Next End Function Function nck(g As Byte, mok As Byte) nck = 1 Dim i As Byte, j As Byte, mn As Byte, ik As Byte, jk As Byte mn = 100 For i = 0 To n_1 For j = 0 To n_1 If p(i, j) = 0 Then If mn > mx(i, j) Then mn = mx(i, j) ik = i jk = j If mn = 0 Then y(g) = ik x(g) = jk Exit Function End If End If End If Next Next y(g) = ik x(g) = jk If mok = 1 Then nck = rhk(g) End If End Function Function klk(g As Byte) '局所リスト解析プロシージャ Dim i As Byte, j As Byte, k As Byte, w As Byte For i = 0 To n_1 For j = 0 To n_1 hth(g, i, j) = 0 Next Next For i = 0 To n_1 If p(y(g), i) = 0 Then For j = 0 To mx(y(g), i) If p(y(g), x(g)) = rlst(y(g), i, j) Then If mx(y(g), i) = 0 Then klk = 0 Exit Function End If hth(g, y(g), i) = 1 For k = 0 To n_1 crlst(g, y(g), i, k) = rlst(y(g), i, k) Next For k = 0 To n_1 ckh(g, y(g), i, k) = kh(y(g), i, k) Next cmx(g, y(g), i) = mx(y(g), i) w = rlst(y(g), i, j) rlst(y(g), i, j) = rlst(y(g), i, mx(y(g), i)) rlst(y(g), i, mx(y(g), i)) = w kh(y(g), i, p(y(g), x(g)) - 1) = 0 mx(y(g), i) = mx(y(g), i) - 1 Exit For End If Next End If Next For i = 0 To n_1 If p(i, x(g)) = 0 Then For j = 0 To mx(i, x(g)) If p(y(g), x(g)) = rlst(i, x(g), j) Then If mx(i, x(g)) = 0 Then klk = 0 Exit Function End If hth(g, i, x(g)) = 1 For k = 0 To n_1 crlst(g, i, x(g), k) = rlst(i, x(g), k) Next For k = 0 To n_1 ckh(g, i, x(g), k) = kh(i, x(g), k) Next cmx(g, i, x(g)) = mx(i, x(g)) w = rlst(i, x(g), j) rlst(i, x(g), j) = rlst(i, x(g), mx(i, x(g))) rlst(i, x(g), mx(i, x(g))) = w kh(i, x(g), p(y(g), x(g)) - 1) = 0 mx(i, x(g)) = mx(i, x(g)) - 1 Exit For End If Next End If Next Dim ybs As Byte, xbs As Byte Dim isy As Byte, ia As Byte ybs = rn * Int(y(g) / rn) xbs = rn * Int(x(g) / rn) For i = 0 To n_1 isy = Int(i / rn) ia = i Mod rn If ybs + isy <> y(g) And xbs + ia <> x(g) And p(ybs + isy, xbs + ia) = 0 Then For j = 0 To mx(ybs + isy, xbs + ia) If p(y(g), x(g)) = rlst(ybs + isy, xbs + ia, j) Then If mx(ybs + isy, xbs + ia) = 0 Then klk = 0 Exit Function End If hth(g, ybs + isy, xbs + ia) = 1 For k = 0 To n_1 crlst(g, ybs + isy, xbs + ia, k) = rlst(ybs + isy, xbs + ia, k) Next For k = 0 To n_1 ckh(g, ybs + isy, xbs + ia, k) = kh(ybs + isy, xbs + ia, k) Next cmx(g, ybs + isy, xbs + ia) = mx(ybs + isy, xbs + ia) w = rlst(ybs + isy, xbs + ia, j) rlst(ybs + isy, xbs + ia, j) = rlst(ybs + isy, xbs + ia, mx(ybs + isy, xbs + ia)) rlst(ybs + isy, xbs + ia, mx(ybs + isy, xbs + ia)) = w kh(ybs + isy, xbs + ia, p(y(g), x(g)) - 1) = 0 mx(ybs + isy, xbs + ia) = mx(ybs + isy, xbs + ia) - 1 Exit For End If Next End If Next klk = 1 End Function Sub hukugen(g As Integer) Dim i As Byte, j As Byte, ybs As Byte, xbs As Byte, isy As Byte, ia As Byte For i = 0 To n_1 If i <> x(g) And p(y(g), i) = 0 Then If hth(g, y(g), i) = 1 Then For j = 0 To n_1 rlst(y(g), i, j) = crlst(g, y(g), i, j) Next For j = 0 To n_1 kh(y(g), i, j) = ckh(g, y(g), i, j) Next mx(y(g), i) = cmx(g, y(g), i) End If End If Next For i = 0 To n_1 If i <> y(g) And p(i, x(g)) = 0 Then If hth(g, i, x(g)) = 1 Then For j = 0 To n_1 rlst(i, x(g), j) = crlst(g, i, x(g), j) Next For j = 0 To n_1 kh(i, x(g), j) = ckh(g, i, x(g), j) Next mx(i, x(g)) = cmx(g, i, x(g)) End If End If Next ybs = rn * Int(y(g) / rn) xbs = rn * Int(x(g) / rn) For i = 0 To n_1 isy = Int(i / rn) ia = i Mod rn If ybs + isy <> y(g) And xbs + ia <> x(g) And p(ybs + isy, xbs + ia) = 0 Then If hth(g, ybs + isy, xbs + ia) = 1 Then For j = 0 To n_1 rlst(ybs + isy, xbs + ia, j) = crlst(g, ybs + isy, xbs + ia, j) Next For j = 0 To n_1 kh(ybs + isy, xbs + ia, j) = ckh(g, ybs + isy, xbs + ia, j) Next mx(ybs + isy, xbs + ia) = cmx(g, ybs + isy, xbs + ia) End If End If Next End Sub Sub hyouji() '問題表示プロシージャ Dim i As Integer For i = 0 To hintosu - 1 Cells(15 + 10 * Int(kz / 40) + cy(i), 2 + 10 * (kz Mod 40) + cx(i)) = cp(cy(i), cx(i)) Next End Sub Sub hyouji2() '問題表示プロシージャ Dim i As Integer For i = 0 To n2_1 Cells(15 + cy(i), 2 + cx(i)) = cp(cy(i), cx(i)) Next End Sub '以下全体リスト構造解析表示プロシージャ 正しいことが確認できた際にもプロシージャ自体は残しておく 'この後のプログラムの進展の際に何回も利用するするから Sub hyouji1() Dim i As Integer, j As Integer For i = 0 To n_1 For j = 0 To n_1 If p(i, j) = 0 Then For k = 0 To n_1 Cells(15 + i, 2 + 10 * j + k) = rlst(i, j, k) Next For k = 0 To mx(i, j) '以下は、マクロの記録から学んだもの Cells(15 + i, 2 + 10 * j + k).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent5 .TintAndShade = 0 .PatternTintAndShade = 0 End With '以上は、マクロの記録から学んだもの Next For k = mx(i, j) + 1 To n_1 '以下は、マクロの記録から学んだもの Cells(15 + i, 2 + 10 * j + k).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent2 .TintAndShade = 0.388845066682843 .PatternTintAndShade = 0 End With '以上は、マクロの記録から学んだもの Next Else For k = 0 To n_1 Cells(15 + i, 2 + 10 * j + k) = "＊" Next End If Next Next End Sub Function kensyou(a() As Integer, n As Integer) Dim b(80) As Byte, i As Integer, j As Integer For i = 0 To n2_1 b(i) = 0 Next For i = 0 To n_1 For j = 0 To n_1 b(a(i, j)) = 1 Next Next For i = 0 To n_1 If b(i) = 0 Then kensyou = 0 Exit Function End If Next kensyou = 1 End Function Private Sub CommandButton2_Click() Rows("4:50000").Select Selection.ClearContents ' Rows("15:35").Select ' Selection.Delete Range("A1").Select End Sub