If the numbers are arranged in the shape above,
lines can be drawn as shown below.
A technique for solving both Sudoku and Slitherlink with the use of Excel VBA was considered for a long time. Although Sudoku is more compatible with Excel, Slitherlink is difficult and complicated. Excel is designed for spreadsheet purposes, not for creating documents or puzzles. But it's worth considering. Japanese
Figure 1. is a diagram showing how to solve a slitherlink puzzle. As can be seen, same number of lines are drawn around the squares so that the whole becomes one circle. For basic procedure, 4 examples are also presented in Figure 1, but many techniques are needed for solving a puzzle.
For the third procedure (where, two 3's are diagonally adjacent), VBA expression is as follow. For cell c,
If c.Value = 3 And c.Range("b2").Value = 3 Then
With c.Borders(xlEdgeLeft): .Weight = xlThick: .ColorIndex = 9
End With
……
……
……
End If
As consideration must also be taken to the case where the positional relationship is multifaceted symmetrical, VBA code will exceed 1,000 lines. Aiming for about 200 lines, difficulty of reading program would be unavoidable.
Figure 2 shows a typical format of this puzzle. It is possible to have 6 to 25 squares in both vertical and horizontal directions.
VBA will start with a MsgBox (message box) "Start?". No (N) aborts, but Cancel displays another message "InputBox", and clears the borders to their initial state. The InputBox allows you to choose the border color. Starting color is chestnut color as is shown in Figure 3.
Figure 3. is an example of completed one. Ideally, pencil puzzles can be solved without using an eraser.
In the solution here, a puzzle would be cleared in normal mode, if a degree of difficulty is at around 2 in 5 stages. When it get stuck, it will pause and ask if you want to continue in "trial mode". In trial mode, VBA will find an answer using an eraser.
A progress message will be displayed approximately every 30 seconds asking if you would like to continue. It is possible to stop temporarily with No (N) reply in the "MsgBox", and to add hints, and to continue. if adding involve a mistake or the originally impossible puzzle, VBA will stop displaying the "Error" message.
Figure 4．Example
| 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 |
Paste into the c3 cell of the Excel worksheet. It is best to create an outer frame.
Below is a memo.
xlEdgeLeft=7 左 c7
xlEdgeTop=8 上 c8
xlEdgeRight=10 右 c10
xlEdgeBottom=9 下 c9
左上 c1 右上 c2
右下 c3 左下 c4
CurrentStatus ABCD ---- abcd
DL Draw ABCD Erase abcd
A variety of techniques are shown in Figure 5.
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 "number of squares are small": 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? clear, color change=cancel、Abort=n", vbYesNoCancel): If a = vbNo Then End
If a = vbCancel Then CoL = InputBox("color number, End = cancel" & vbCr & "red3 bluw5 vioret7 "): _
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("continue in 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 "infinite loop": 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
