Wikipedia says the following for the Knight’s tour :
A knight’s tour is a sequence of moves of a knight on a chessboard such that the knight visits every square only once. If the knight ends on a square that is one knight’s move from the beginning square (so that it could tour the board again immediately, following the same path), the tour is closed, otherwise it is open.
I have decided to try to simulate the Knight’s tour with Excel. Something like this was achieved after some time:
So, what do we have? A VBA code, in which we give the size of the matrix. The minimum matrix is 5×5, the maximum is Excel width x Excel width. 🙂
Once we give it, the algorithm, using the Warnsdorf’s rule start working. The rule is in short like this – the knight should go into the position, from which we have the less possible positions to go next. I don’t know about you, but this really sounded like a recursion to me, so I have implemented it. The recursion sub-routine in my code is named “CalculatePriceWithItalic”, because initially I was using italic font to note where my knight has already stepped. From the pictures above, you understand that you start with 1, then the knight goes to 2, then 3, then 4 and etc. The red square is the square of the current position of the knight. It is red, just to make the animation.
Long story short – here comes the code. If you want to run it, simply write “Main” in the immediate window. To change the matrix size, change the value of l_counter in the main function. If you do not want animation (why would you not want animation) you may set the value of b_animate to false:
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
Option Explicit Public r_range As Range Public r_used_range As Range Public l_result As Long Public Sub DeleteOthers() Dim r_cell As Range For Each r_cell In r_used_range If r_cell.Interior.Color <> vbGreen Then r_cell.ClearContents Next r_cell End Sub Public Sub CalculatePriceWithItalic(r_cell As Range, l_size As Long, Optional b_once As Boolean = False) Dim r_row As Range Dim r_col As Range Dim my_cell As Range Dim l_row As Long Dim l_col As Long l_result = 0 'RIGHT l_row = r_cell.Row + 1 l_col = r_cell.Column + 2 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) l_row = r_cell.Row - 1 l_col = r_cell.Column + 2 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) 'DOWN l_row = r_cell.Row + 2 l_col = r_cell.Column + 1 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) l_row = r_cell.Row + 2 l_col = r_cell.Column - 1 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) 'LEFT l_row = r_cell.Row - 1 l_col = r_cell.Column - 2 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) l_row = r_cell.Row + 1 l_col = r_cell.Column - 2 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) 'UP l_row = r_cell.Row - 2 l_col = r_cell.Column - 1 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) l_row = r_cell.Row - 2 l_col = r_cell.Column + 1 Call CheckRow(l_row, l_col, l_size, r_cell, b_once) r_cell = l_result Set my_cell = Nothing End Sub Public Sub CheckRow(l_row As Long, l_col As Long, l_size As Long, r_cell As Range, b_once As Boolean) If l_row <= l_size And l_col <= l_size And l_row > 0 And l_col > 0 Then If Len(Cells(l_row, l_col)) < 1 And Cells(l_row, l_col).Address <> r_cell.Address Then l_result = l_result + 1 If b_once Then Call CalculatePriceWithItalic(Cells(l_row, l_col), l_size) End If End If End Sub Sub main() Dim my_array() As Variant Dim my_array_b() As Variant Dim l_counter As Long Dim l_counter_2 As Long Dim l_counter_moves As Long: l_counter_moves = 1 Dim my_cell As Range Dim b_animate As Boolean Dim l_starting_row As Long Dim l_starting_col As Long b_animate = True l_counter = 8 l_starting_row = 8 l_starting_col = 8 If l_starting_row > l_counter Or l_starting_row < 1 Then l_starting_row = l_counter If l_starting_col > l_counter Or l_starting_col < 1 Then l_starting_col = l_counter Call OnStart(b_animate) ReDim my_array(l_counter) Set r_used_range = Range(Cells(1, 1), Cells(100, 100)) r_used_range.Clear Set r_used_range = Range(Cells(1, 1), Cells(l_counter, l_counter)) r_used_range.Clear Call FormatRangeInitially(r_used_range) For l_counter_2 = 1 To l_counter ReDim my_array_b(l_counter) my_array(l_counter_2) = my_array_b Next l_counter_2 Set my_cell = Cells(l_starting_row, l_starting_col) While l_counter_moves <= (l_counter ^ 2) Call CalculatePriceWithItalic(my_cell, l_counter, True) Call FormatMyCell(my_cell, l_counter_moves, 1) If b_animate Then Application.Wait (Now + TimeValue("00:00:01")) Call FormatMyCell(my_cell, l_counter_moves, 2) l_counter_moves = l_counter_moves + 1 Set my_cell = FindNextTarget Call DeleteOthers Wend Set r_used_range = Nothing Set r_range = Nothing Set my_cell = Nothing Call OnEnd End Sub Function FindNextTarget() As Range Dim my_next As Range Dim lowest As Long: lowest = 9999 For Each my_next In r_used_range If my_next.Value < lowest And my_next.Value > 0 And my_next.Interior.Color <> vbGreen Then lowest = my_next.Value Set FindNextTarget = my_next End If Next my_next End Function Sub FormatMyCell(ByRef my_cell_range As Range, l_counter As Long, l_color As Long) If l_color = 2 Then my_cell_range.Interior.Color = vbGreen If l_color = 1 Then my_cell_range.Interior.Color = vbRed my_cell_range = l_counter End Sub Public Sub FormatRangeInitially(r_range As Range) r_range.HorizontalAlignment = xlCenter r_range.Borders(xlDiagonalDown).LineStyle = xlNone r_range.Borders(xlDiagonalUp).LineStyle = xlNone With r_range.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With r_range.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With r_range.ColumnWidth = 3.2 End Sub Public Sub OnStart(b_animate As Boolean) Application.DisplayAlerts = False If Not b_animate Then Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False End Sub Public Sub OnEnd() 'Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False End Sub |
The code and the file are available in GitHub here!
Enjoy! 😀