Excel VBA を使って数独およびスリザーリンクを解く方法を長い間模索してきました。数独の方はどちらかというと Excel と相性がありますが スリザーリンクは困難なので一時は断念していました。Excel は Lotus123 の流れを汲み 表計算を目的に設計されていて、文書を作成したりパズルに使うのは本筋ではありません。しかし検討する価値はあると思います。表の罫線には色、線種、太さなど修飾機能が豊富に用意されてはいますが全体からみれば特に重要ではなく、そもそも VBA で罫線を操作することは想定外なのか、一部不具合も見当たります。
スリザーリンクの解き方を示す図を毎日新聞から借用したのが図1. です。数字のあるマスの周囲には同じ数の線を引き全体が１つの輪になるようにします。基本手筋として４例が挙げられていますが、問題を解くには 多くの手筋が必要です。
例えば、３番目の手筋 （ 斜めに ３ が隣接する場合 ） を VBA で表すと セル c に対して、
If c.Value = 3 And c.Range("b2").Value = 3 Then
With c.Borders(xlEdgeLeft): .Weight = xlThick: .ColorIndex = 9
End With
……
……
……
End If
等と丁寧に列挙していくと位置関係が対称である場合も考慮しなければならず 1,000 行をはるかに超えてしまいます。２００行程度を目標にして、判読が困難になることはやむを得ないとしました。因みに、上記３番目の手筋で２つの３の間に２が１つあるいは複数連続して存在する場合も成立します。次のようにすると２が存在しない場合 （ Do 以下 Loop までが無視されます ）も含めて表記できます。
If c.Value = 3 Then
Set nc = c.Range("b2"): Do While nc.Value = 2: Set nc = nc.Range("b2"): Loop
If nc.Value = 3 Then
……
……
……
Set b = nc.Borders(xlEdgeBottom): b.Weight = xlThick: b.ColorIndex = 9
End If
End If
図2. のような書式で問題範囲の外枠左上端が B2 ～ H8 セルの範囲内に位置するようにします。縦、横それぞれのマス数を ６ ～ ２５まで可能にしています。問題範囲の外周枠線は自動的に作成されるので 図4．のようなので OK です。但し 問題範囲に " 格子 " の枠線を引いておく必要があります。
図2,、図3. では通常の ワークシート と違い背景の枠線がありません。このほうが分かり易いので列幅ともに VBA が設定します。枠線をもとに戻すには 『 表示 』 → 『 枠線 』 （ Excel2003では 『 ツール 』 → 『 オプション 』のダイアログボックスから ）のチェックボックスで操作します。
パズルの罫線を 最初から無罫線にしたり太い罫線にすると誤動作します。VBA が起動すると、"Start？” のメッセージボックス が表示されます。 いいえ（N) で 中止しますが、キャンセルで さらに InputBox が表示され 罫線が最初の状態にクリアされます。InputBox では罫線の色を好みの色に変更でき、指定色で開始します。最初は 図3．のように 栗毛色です。
図3. は解答済みの例です。ペンシルパズル は消しゴムを使わずに解ける問題が理想です。コンピューターを利用し、虫食い算や数独を順列乱数などから解答を求めると早くて簡単です。しかし、これでは複数の答えが見つかることもありパズルの意味がありません。
ここの解法では、難易度 ５段階にして ２ 程度なら通常モードでクリアできると考えています。通常モードで行き詰まると 一旦中断して、trial mode で続行するかを尋ねてきます。trial mode では消しゴムを使い解答を探します。速度を高めるため画面更新はしませんが 概ね ３０秒毎に途中経過と ”さらに継続するか ” のメッセージが表示されます。高速処理中は Ctrl + Break で中断できないことが多いのでキーに触れず待つのがよいでしょう。メッセージボックスに対して いいえ（N) で一旦中止し、自身で加筆して あるいはそのままで start 再開することが可能です。trial 中の中止では確定場面に戻ります。加筆が誤っていたり、当初から不可能な問題等では Error 表示して終了し、難問では最終画面で Give UP します。消しゴム使用後の復元のため シートの BA1 ～ CM80 のセル範囲を使用しているので、ここにデータがあると消去されてしまいます。
図4．例題
| 2 | 2 | 3 | 2 | 1 | 1 | 0 | 2 | 3 | 2 | 3 | 2 | 0 | 3 | 1 | 2 | 2 | 1 | 2 | 0 | 2 | 1 | 2 | 2 | 3 | 2 | 2 | 1 | 1 | 0 | 1 | 2 | 2 | 3 | 3 | 0 | 3 | 1 | 2 | 3 | 2 | 1 |
Excel ワークシートの c3 セルに貼り付け 外枠を作成するのがベストです。
以下は備忘録です。
xlEdgeLeft=7 左 c7
xlEdgeTop=8 上 c8
xlEdgeRight=10 右 c10
xlEdgeBottom=9 下 c9
左上 c1 右上 c2
右下 c3 左下 c4
CurrentStatus ABCD ---- abcd
DL Draw ABCD Erase abcd
主な手筋を図5．に列挙します。上部の二例からわかるように黒色の状態の場合には赤のように確定することができます。① ～ ③、⑩ 、⑪では 辺や縁の場合を想定していますが、同じ条件が満たされれば何処であっても成立します。
[ trial mode について ] … 行き詰まった場面を P1 とします。 手筋を使い切っているので 『 次の一手 』 として適当な場所に根拠もなく線を引いて反応をみることにします。具体的には左上端のセルから順番に未確定の枠線を探して実行します。次の一手 に対して
① 継続が皆無、あるいは数手しか進まない
② 一気に数十手以上進む
③ 成功画面に到達する
が考えられます。③ はラッキーですが、多くは ① で次候補の枠線に手が移ります。② でエラー発生すると次の一手が誤りだったということになります。（ エラーとは 罫線の交差、小さい輪を作る等のことです ）訂正し新しい P1 の地点まで進められます。エラーにならない場合は 仮想の到達点 P2 を設定し、P1 と同様に次の一手で進めて、単独エラーだけの順風ならゴールまで進めます。しかしダブルエラー発生時の処理が重要です。P2 の到達点がどこであっても、エラー訂正した上でのエラーであれば P1 の地点に戻っての次の一手を訂正する必要があります。” ふりだし “ に戻りますが確実に先に進めます。
以上のように trial mode での解答所要時間は 次の一手を選ぶ運次第です。パズル画面を左右や上下に反転するだけで大きく変化することがあります。ペンシルを持って実際にパズルを解く者にとっては 次の一手を効果的に見つけ消しゴムを使わず早く処理することが重要です。VBA でこれを求めるのは至難です。
Dim c0, St(5), wRange, myRange, Qt, OK, CoL, Smd, Er As Boolean
Sub slither() ' ==== SlitherLink ver.5.5.4 ====
Dim c01 As Range, Rc(4), Qc(4) As Range, Ar(11)
For Each c In Range("a1:h8"): If c.Borders(7).LineStyle = 1 Then Set c01 = c: Exit For
Next: If c01 Is Nothing Then MsgBox "Range Missing": End
If c01.Row = 1 Or c01.Column = 1 Then c01.EntireRow.Insert: c01.EntireColumn.Insert
For i = 1 To 27: If c01.Cells(i + 1, 1).Borders(7).LineStyle <> 1 Then y = i: Exit For
Next '(注）xlEdgeLeft=7, xlEdgeTop=8, xlEdgeRight=10 xlEdgeBottom=9 xlSolid=1
For i = 1 To 27: If c01.Cells(1, i + 1).Borders(8).LineStyle <> 1 Then x = i: Exit For
Next: If x * y < 36 Then MsgBox "縦横マス数が少ないです": End
Set c02 = c01.Cells(y, x): Set wRange = Range(c01, c02)
If c01.Borders(10).LineStyle = 1 Then
c01.EntireRow.Insert: c01.EntireColumn.Insert: Set c01 = c01.Offset(-1, -1): Set c02 = c02.Range("b2")
Set wRange = Range(c01, c02): wRange.BorderAround Weight:=xlThin
End If: Set P0 = c01: Set c0 = c01.Range("b2"): Set myRange = Range(c0, c02.Offset(-1, -1)): CoL = 9
Rg = Range(c01, c02.Range("B2")): St(0) = Rg: St(1) = Rg: St(2) = Rg: St(3) = Rg: St(4) = Rg: St(5) = Rg
wRange.ColumnWidth = 3.4: wRange.RowHeight = 22.6: ActiveWindow.DisplayGridlines = False
a = MsgBox("Start? クリア色変更=キャンセル、中止=いいえ(N)", vbYesNoCancel): If a = vbNo Then End
If a = vbCancel Then CoL = InputBox("色変更は番号 終了=キャンセル" & vbCr & "赤3 青5 紫7 栗毛9"): _
wRange.Borders.LineStyle = 0: wRange.BorderAround Weight:=xlThin: myRange.Borders.Weight = xlThin
y = wRange.Rows.Count: x = wRange.Columns.Count: Smd = 2: If CoL = "" Then End
Set P1 = Range("BA2"): Set P2 = Range("BA42"): w = "a1:" & Chr(96 + x) & y: Set Rg1 = P1.Range(w)
Set Rg2 = P2.Range(w): Set Bd = Range("a1").Borders(7): If CoL = 3 Or CoL = 5 Or CoL = 7 Then Else CoL = 9
myLoop: Call CurrentStatus(c)
For Each c In Range(c0, c02): Set c1 = S(c, 1): Set c2 = S(c, 2): Set c3 = S(c, 3): Set c4 = S(c, 4): Set c7 = S(c, 7)
Set c8 = S(c, 8): Set c9 = S(c, 9): Set c10 = S(c, 10): L = fS(c, 2): n = fS(c, 3): u = fS(c, 4): v = c.Value
If v <> "" And v = 0 Then DL c, "", 0 '==== ０ の場合と <3^3^3>
If v = 3 And c3.Value = 3 Then If c.Range("c1").Value = 3 Then DL c10, "b", 0 Else If c2.Value = 3 Then _
DL c10, "c", 0 Else If c4.Value = 3 Then DL c9, "d", 0 Else If c.Range("a3").Value = 3 Then DL c9, "a", 0
If u > 0 Then If v = L + u Then DL c, "", 1 Else If (L > 0 And v = L) Or L = 3 Then DL c, "", 0 '=== 罫線飽和や完了時
Set Rc(1) = c1: Set Rc(2) = c2: Set Rc(3) = c3: Set Rc(4) = c4: Set Qc(1) = c10: Set Qc(2) = c9: Set Qc(3) = c7
Set Qc(4) = c8: Ar(0) = Array(1, 2, 3, 4, 1, 2, 3): Ar(1) = Split(" ABC BCD CDA DAB"): Ar(2) = Split(" AB BC CD DA")
Ar(3) = Split(" A B C D"): Ar(4) = Split(" a b c d"): Ar(5) = Split(" -b -c -d -a"): Ar(6) = Split(" ab bc cd da")
Ar(7) = Split(" A|B B|C C|D D|A"): Ar(8) = Split(" Ab|aB Bc|bC Cd|cD Da|dA")
Ar(9) = Split(" A-|-B B-|-C C-|-D D-|-A"): Ar(10) = Split(" a-|-b b-|-c c-|-d d-|-a")
For i = 1 To 4: k = Ar(0)(i): j = Ar(0)(i + 1): m = Ar(0)(i + 2)
If L = 4 Or L + u < v Or (v > 0 And L > v) Or (F(Rc(i), Ar(2)(j)) And F(c, Ar(3)(i) & "|" & Ar(3)(k))) Or _
(F(Rc(i), Ar(6)(j)) And F(c, Ar(8)(i))) Then Er = True: Exit For '=== Errorの場合
If F(Qc(j), Ar(1)(m)) Then If L = 2 And u > 0 Then DL c, "", 0 Else If L = 3 Then Er = True: Exit For
If F(Qc(j), Ar(1)(m)) And (F(Qc(m), Ar(1)(i)) Or F(Qc(i), Ar(1)(k))) Then _
If L = 1 And u > 0 Then DL c, "", 0 Else If L = 2 Then Er = True: Exit For
If (F(Rc(i), Ar(1)(m)) And F(Qc(m), Ar(2)(k))) Or (F(Rc(m), Ar(1)(m)) And F(Qc(k), Ar(2)(j))) Then _
If L = 2 And u > 0 Then DL c, "", 0 Else If L = 3 Then Er = True: Exit For
If v = 1 And Qc(i).Value = 1 And F(Rc(k), Ar(5)(m)) Then DL c, Ar(3)(j), 0: _
If Qc(k).Value = 3 Or Rc(j).Value = 3 Then DL c, Ar(3)(k), 0 '===① 1 | 1 ①' 1 | 1 の場合
If v = 1 And Qc(i).Value = 3 And F(Rc(k), Ar(5)(m)) Then DL c, Ar(2)(m), 0: DL Qc(i), Ar(3)(k), 1 '===② 1 | 3 の場合
If v = 3 And Qc(i).Value = 1 And F(Rc(k), Ar(5)(m)) Then DL Qc(i), Ar(2)(j), 0: DL c, Ar(3)(k), 1 '===② 3 | 1 の場合
If v = 3 And Qc(i).Value = 3 Then '== 3 | 3の場合
DL c, Ar(3)(i), 1: DL c, Ar(3)(j), 1: DL Rc(k), Ar(3)(i), 0: If Rc(k).Value = 2 Then DL Rc(k), Ar(3)(k), 1
If Rc(j).Value = 2 Then DL Rc(j), Ar(3)(m), 1
End If
If v = 3 And Rc(i).Value = 3 Then DL Rc(i), Ar(2)(i), 1: DL c, Ar(2)(j), 1 '=== <3 3> の場合
If F(Rc(i), Ar(6)(j)) And u > 0 Then '=== ③ 0 > 3 ④ 0 > 1, ┌ & ┛ ⑥ 0 > 2 └ & ┐ ⑦ 0 >2> 1 の場合
If v = 3 Then DL c, Ar(2)(i), 1 Else If v = 1 Then DL c, Ar(2)(i), 0 _
Else If v = 2 And Rc(j) = 1 Then DL Rc(j), Ar(2)(i), 0 Else If F(c, Ar(2)(j)) Then DL c, Ar(2)(i), 0
If v = 2 And (F(c, Ar(10)(j)) Or F(Rc(j), Ar(7)(i))) Then DL c, Ar(2)(i), 1
If F(Rc(j), Ar(6)(i)) Then If F(Rc(k), Ar(6)(m)) Or F(Rc(m), Ar(2)(k)) Then Call DL(c, "", 0) '===└ & ┐
End If '=== ⑤ 0 >1> 3 ⑧罫線 ３ に接近の場合 ⑨罫線 １ に接近の場合 ⑯⑰ 罫線 ２ に接近の場合 = 曲進不可
If v = 1 And F(c, Ar(6)(i)) And Rc(j).Value = 3 Then DL Rc(j), Ar(2)(j), 1 '=== ⑤ 0 >1> 3
If F(Rc(i), Ar(7)(j)) And v = 3 Then DL c, Ar(2)(j), 1 Else If F(Rc(i), Ar(8)(j)) And v = 1 Then DL c, Ar(2)(j), 0
If F(Rc(i), Ar(9)(j)) And (v = 3 Or (v = 2 And (F(Rc(j), Ar(9)(i)) Or F(c, Ar(10)(j))))) Then DL Rc(i), Ar(6)(j), 0
If F(Rc(i), Ar(6)(j)) And F(c, Ar(9)(i)) Then DL c, Ar(2)(i), 1 '====曲進行の場合
If F(c, Ar(3)(k) & Ar(4)(j)) And F(Rc(k), Ar(5)(m)) Then DL Rc(k), Ar(3)(m), 1 '==== 直進の場合
If F(Rc(m), Ar(3)(k) & Ar(4)(j)) And F(c, Ar(5)(m)) Then DL c, Ar(3)(m), 1 '==== 直進2
If F(c, Ar(2)(i)) And F(Rc(i), "-") Then DL Rc(i), Ar(6)(j), 0 '==== 曲進消去
If F(Rc(i), Ar(6)(j)) And F(c, Ar(10)(i)) Then DL c, Ar(6)(i), 0 '==== 行止の場合
If F(c, Ar(3)(i) & "-") And F(Rc(i), Ar(3)(j)) Then DL c, Ar(3)(k), 0: DL Rc(i), Ar(3)(m), 0 '== ┨ ┷ の場合
If F(Rc(i), Ar(6)(j)) And v = 2 Then If F(Rc(k), Ar(5)(m)) Then DL Rc(k), Ar(3)(m), 1 _
Else If F(Rc(m), Ar(4)(k)) Then DL Rc(m), Ar(3)(j), 1 '===⑩ 0 > 2 Right
If (F(Rc(i), Ar(6)(j)) Or F(Rc(k), Ar(6)(m))) And F(Rc(j), Ar(4)(k)) And F(Rc(m), Ar(4)(k)) And _
Qc(k).Value = 3 Then DL c, Ar(3)(m), 1 '=== ⑮ 0 > ? | 3
If Rc(i).Value <> 2 And v = 2 And Rc(j).Value = 2 Then Set R = Rc(j): Do While R.Value = 2: Set R = S(R, j): Loop: _
If R.Value = 3 Then If Rc(i).Value = 3 Or F(Rc(i), Ar(7)(j)) Or (Rc(i).Value = 1 And F(Rc(i), Ar(6)(i))) Then _
DL R, Ar(2)(j), 1 Else If F(Rc(i), Ar(6)(j)) Then DL R, Ar(2)(i), 1 '=== <3 2 2 2 2 2 2 3>
If v = 2 And Rc(j).Value = 3 Then ' === 0 < 1 > 2 >3 0> 2 >3 <3 2 3> ⑫ ⑬ ⑭
If Rc(i).Value = 3 Or F(Rc(i), Ar(7)(j)) Or (Rc(i).Value = 1 And F(Rc(i), Ar(6)(i))) Then DL Rc(j), Ar(2)(j), 1 _
Else If F(Rc(i), Ar(6)(j)) Then DL Rc(j), Ar(2)(i), 1
If F(c, Ar(10)(i)) Or F(Rc(k), Ar(6)(m)) Or F(Rc(m), Ar(6)(k)) Then DL Rc(j), Ar(2)(j), 1: If F(c, Ar(4)(i)) Then _
DL c, Ar(3)(k), 1 Else If F(c, Ar(4)(k)) Then DL c, Ar(3)(i), 1
End If: Next: If Er = True Then Exit For
Next: If Smd > 0 And Er = True Then MsgBox "Unexpected error": End
If Er = False And Qt > 0 Then Qt1 = Qt1 + Qt: Qt = 0: GoTo myLoop
For Each c In myRange: D = "": If F(c, "AB") Then D = "42" Else If F(c, "CD") Then D = "24"
If D <> "" Then Call Cood(c, Val(Left(D, 1)), Val(Right(D, 1))): If OK = True Then OK = False: GoTo myLoop
Next
If Smd = 2 Or Timer - swT > 30 Then
Application.ScreenUpdating = True: a = MsgBox("trial mode でさらに継続しますか?", vbYesNo): swT = Timer
If a = vbNo Then If Smd > 0 Then Call Fin(c) Else If Smd < 1 Then Rg1.Copy P0: Call Fin(c)
End If: Qt2 = Qt1: Qt1 = 0: Application.ScreenUpdating = False
If Smd = 0 And Er = False And Qt2 > 30 Then Set Bd0 = Bd: Qt2 = 0: wRange.Copy P2: Smd = -1
If Smd = 0 Then Rg1.Copy P0 Else If Smd = -2 Then Rg2.Copy P0
If Er = True Then
Select Case Smd
Case 0: Bd.LineStyle = xlNone: Smd = 1: Case -1: Rg1.Copy P0: Bd0.LineStyle = xlNone: Smd = 1
Case -2: Bd.LineStyle = xlNone: Smd = -1: End Select: hst = "!" & hst: Er = False: GoTo myLoop
End If
Call Ttest(Bd, hst): If Smd >= 0 Then wRange.Copy P1: Smd = 0 Else If Smd < 0 Then wRange.Copy P2: Smd = -2
Bd.Weight = 4: Bd.ColorIndex = CoL: GoTo myLoop
End Sub
Sub Fin(c)
Range("BA1:CM80").Clear: End
End Sub
Sub Cood(c, d1, d2)
If Er = True Then Exit Sub Else Set c5 = c: St(5) = wRange: Call SL(c5)
Do: mug = mug + 1: If mug > 10 And c.Address = c5.Address Then Er = True: Exit Do
Select Case d1
Case 1: Set R = S(c5, 1): If F(c5, "B") Then d1 = 2 Else If F(R, "C") Then Set c5 = S(R, 10): d1 = 1: Call SL(c5) _
Else If F(R, "D") Then Set c5 = R: Call SL(c5): d1 = 4 Else Set hr1 = c5: Set vt1 = S(c5, 8): Exit Do
Case 2: Set R = S(c5, 2): If F(c5, "C") Then d1 = 3 Else If F(R, "D") Then Set c5 = S(R, 9): d1 = 2: Call SL(c5) _
Else If F(R, "A") Then Set c5 = R: Call SL(c5): d1 = 1 Else Set hr1 = S(c5, 10): Set vt1 = S(c5, 10): Exit Do
Case 3: Set R = S(c5, 3): If F(c5, "D") Then d1 = 4 Else If F(R, "A") Then Set c5 = S(c5, 9): d1 = 3: Call SL(c5) _
Else If F(R, "B") Then Set c5 = R: Call SL(c5): d1 = 2 Else Set hr1 = S(c5, 9): Set vt1 = S(c5, 3): Exit Do
Case 4: Set R = S(c5, 4): If F(c5, "A") Then d1 = 1 Else If F(R, "B") Then Set c5 = S(R, 8): d1 = 4: Call SL(c5) _
Else If F(R, "C") Then Set c5 = R: Call SL(c5): d1 = 3 Else Set hr1 = S(c5, 4): Set vt1 = c5: Exit Do
End Select: Loop: '======成功 終了場面 へ
If Er = True Then Call IsSuc(Success): If Smd < 1 Then Exit Sub Else MsgBox "無限ループです": Call Fin(c)
Set c6 = c: Do: mug = mug + 1: If mug > 800 Then MsgBox "Error ?": Call Fin(c)
Select Case d2
Case 1: Set R = S(c6, 1): If F(c6, "A") Then d2 = 4 Else If F(R, "D") Then Set c6 = S(R, 9): d2 = 1 _
Else If F(R, "C") Then Set c6 = R: d2 = 2 Else Set hr2 = S(c6, 7): Set vt2 = c6: Exit Do
Case 2: Set R = S(c6, 2): If F(c6, "B") Then d2 = 1 Else If F(R, "A") Then Set c6 = S(R, 7): d2 = 2 _
Else If F(R, "D") Then Set c6 = R: d2 = 3 Else Set hr2 = c6: Set vt2 = S(c6, 2): Exit Do
Case 3: Set R = S(c6, 3): If F(c6, "C") Then d2 = 2 Else If F(R, "B") Then Set c6 = S(R, 8): d2 = 3 _
Else If F(R, "A") Then Set c6 = R: d2 = 4 Else Set hr2 = S(c6, 3): Set vt2 = S(c6, 10): Exit Do
Case 4: Set R = S(c6, 4): If F(c6, "D") Then d2 = 3 Else If F(R, "C") Then Set c6 = S(R, 10): d2 = 4 _
Else If F(R, "B") Then Set c6 = R: d2 = 1 Else Set hr2 = S(c6, 9): Set vt2 = S(c6, 9): Exit Do
End Select
Loop: ad1 = hr1.Address: ad2 = hr2.Address: ad3 = vt1.Address: ad4 = vt2.Address
If ad1 = ad2 Then Set b = hr1.Borders(8): If b.LineStyle <> xlNone Then b.LineStyle = xlNone: OK = True: Exit Sub
If ad3 = ad4 Then Set b = vt1.Borders(7): If b.LineStyle <> xlNone Then b.LineStyle = xlNone: OK = True: Exit Sub
End Sub
Sub DL(c, wd, n)
If wd = "" Then wd = "abcd" Else If fS(c, 4) = 0 Then Exit Sub
i = 1: Erf = False: If Asc(wd) > 96 Then Erf = True '=== xlThick=4
wd = UCase(wd): w = Left(wd, 1)
Do While w <> ""
m = 0: Set b = c.Borders(InStr("ABDC", w) + 6): If b.Weight = 4 Then m = 1 Else If b.LineStyle = xlNone Then m = -1
If (m = 1 And n = 0) Or (m = -1 And n = 1) Then If Erf = False Then Er = True
If Er = True Then If Smd < 1 Then Exit Sub Else If Smd > 0 Then c.Activate: MsgBox "Error in " & c.Address: End
If m = 0 Then Qt = Qt + 1: If n = 1 Then b.Weight = xlThick: b.ColorIndex = CoL Else If n = 0 Then b.LineStyle = xlNone
i = i + 1: w = Mid(wd, i, 1)
Loop
End Sub
Sub CurrentStatus(c)
For Each c In wRange: w = "": L = 0: m = 0: n = 0
For i = 7 To 10: j = i: If i = 9 Then j = 10 Else If i = 10 Then j = 9
Set b = c.Borders(i): If b.Weight = 4 Then L = L + 1: w = w & Chr(58 + j) _
Else If b.LineStyle = xlNone Then n = n + 1: w = w & Chr(90 + j) Else w = w & "-"
Next: w1 = Left(w, 2) & Right(w, 1) & Mid(w, 3, 1): w = w1 & w1
Call Lst(c, 1, w): Call Lst(c, 2, L): Call Lst(c, 3, n): Call Lst(c, 4, 4 - L - n)
Next
End Sub
Sub Ttest(Bd, hst)
TrAg: For j = 1 To 2
For Each c In myRange
If (j = 1 And fS(c, 4) = 1) Or (j > 1 And fS(c, 4) > 0) Then
For i = 7 To 10
If c.Borders(i).LineStyle = 1 And c.Borders(i).Weight = xlThin Then
If i = 9 Then w2 = c.Range("a2").Address & "8" Else If i = 10 Then w3 = c.Range("b1").Address & "7"
w = c.Address & i: If InStr(hst, w) Then Else hst = hst & w & w2 & w3: Set Bd = c.Borders(i): Exit Sub
End If: Next i: End If: Next: Next j
If InStr(hst, "!") Then hst = "": GoTo TrAg
MsgBox "Give UP": Call Fin(c)
End Sub
Sub SL(c)
Dim Sc(4): Set Sc(1) = S(c, 7): Set Sc(2) = S(c, 8): Set Sc(3) = S(c, 9): Set Sc(4) = S(c, 10)
Call Lst(c, 5, 0): For i = 1 To 4: If c.Borders(i + 6).Weight = 4 Then Call Lst(Sc(i), 5, 0)
Next
End Sub
Sub Lst(c, id, wd)
x = c.Column - c0.Column + 2: y = c.Row - c0.Row + 2: St(id)(y, x) = wd
End Sub
Sub IsSuc(Success)
For Each c In myRange: If fS(c, 5) > 0 Then Exit Sub
Next
For Each c In myRange: For i = 7 To 10: Set b = c.Borders(i)
If b.LineStyle = 1 And b.Weight = xlThin Then b.LineStyle = xlNone
Next: Next: Application.ScreenUpdating = True: MsgBox "completed": Call Fin(c)
End Sub
Function F(c, w)
F = False: x = c.Column - c0.Column + 2: y = c.Row - c0.Row + 2: w0 = St(1)(y, x): n = InStr(w, "|")
If n = 0 Then If InStr(w0, w) Then F = True: Exit Function Else Exit Function
If InStr(w0, Left(w, n - 1)) Or InStr(w0, Right(w, Len(w) - n)) Then F = True: Exit Function
End Function
Function S(c, n)
Select Case n: Case 1: Set S = c.Offset(-1, -1): Case 2: Set S = c.Offset(-1, 1)
Case 3: Set S = c.Range("b2"): Case 4: Set S = c.Offset(1, -1): Case 7: Set S = c.Offset(0, -1)
Case 8: Set S = c.Offset(-1, 0): Case 9: Set S = c.Range("a2"): Case 10: Set S = c.Range("b1"): End Select
End Function
Function fS(c, n)
x = c.Column - c0.Column + 2: y = c.Row - c0.Row + 2: fS = St(n)(y, x)
End Function
