VBAサンプル集
ナンバーリンク(パズル)を解くVBAに挑戦№7

ExcelマクロVBAの実用サンプル、エクセルVBA集と解説
最終更新日：2017-11-26

ナンバーリンク(パズル)を解くVBAに挑戦№7


総仕上げとして、見栄えを良くします。


ちゃんと、数字と数字が線でつながっているようにします。

dispCell

これを拡張します。

getBeforeCell

指定位置にくる直前の位置を取得

getAfterCell

指定位置が進んだ直後のを取得


これらを使用し、


dispCell

の中で、線にしていきます。

では、これを組み込んだコードです。



Option Explicit

Private SuAry(1 To 10, 1 To 10) As String
Private SuAry2(1 To 10, 1 To 10) As String
Private DispRange As Range

Sub main()
　　Debug.Print Now()
　　Dim iR As Integer
　　Dim iC As Integer
　　
　　Set DispRange = Range("B2:K11")
　　DispRange.NumberFormat = "@"
　　For iR = 1 To 10
　　　　For iC = 1 To 10
　　　　　　With DispRange(iR, iC)
　　　　　　　　If .Value = "" Or Not IsNumeric(.Value) Then
　　　　　　　　　　.Value = ""
　　　　　　　　　　.Font.Size = 20
　　　　　　　　　　.Font.Bold = False
　　　　　　　　　　SuAry(iR, iC) = ""
　　　　　　　　Else
　　　　　　　　　　SuAry(iR, iC) = .Value
　　　　　　　　End If
　　　　　　End With
　　　　Next
　　Next
　　
　　iR = 1
　　iC = 0
　　Call getStart(iR, iC)
　　Do
　　　　If getAdvance(iR, iC, iR, iC, 0) = "完了" Then
　　　　　　Exit Do
　　　　End If
　　Loop
　　Call dispCell(True)
　　Debug.Print Now()
End Sub

Private Function getAdvance(ByVal iR As Integer, ByVal iC As Integer, _
　　　　　　　　　　　　　　ByVal iR2 As Integer, ByVal iC2 As Integer, _
　　　　　　　　　　　　　　ByVal tryCnt As Integer) As String
　　Dim iR3 As Integer
　　Dim iC3 As Integer
　　Dim iR4 As Integer
　　Dim iC4 As Integer
　　Dim i As Integer
　　Dim strMust As String
　　Dim rtn As String
　　
　　Call getEnd(iR4, iC4, SuAry(iR, iC))
　　
　　Select Case True
　　　　Case iR4 = iR2 - 1 And iC4 = iC2, _
　　　　　　 iR4 = iR2 And iC4 = iC2 + 1, _
　　　　　　 iR4 = iR2 + 1 And iC4 = iC2, _
　　　　　　 iR4 = iR2 And iC4 = iC2 - 1
　　　　　　Call dispCell(True)
　　　　　　tryCnt = 0
　　　　　　If getStart(iR, iC) = False Then
　　　　　　　　getAdvance = "完了"
　　　　　　　　Exit Function
　　　　　　End If
　　　　　　rtn = getAdvance(iR, iC, iR, iC, tryCnt)
　　　　　　Select Case rtn
　　　　　　　　Case "完了"
　　　　　　　　　　getAdvance = "完了"
　　　　　　　　　　Exit Function
　　　　　　　　Case "終点"
　　　　　　　　　　getAdvance = "終点"
　　　　　　　　　　tryCnt = 0
　　　　　　　　　　If getStart(iR, iC) = False Then
　　　　　　　　　　　　getAdvance = "完了"
　　　　　　　　　　　　Exit Function
　　　　　　　　　　End If
　　　　　　　　Case "破綻"
　　　　　　　　　　getAdvance = "破綻"
　　　　　　　　　　Exit Function
　　　　　　End Select
　　End Select
　　
　　For i = 1 To 4
　　　　Select Case True
　　　　　　Case iR4 > iR2 And iC4 > iC2
　　　　　　　　Select Case i
　　　　　　　　　　Case 1
　　　　　　　　　　　　iR3 = iR2 + 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 2
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 + 1
　　　　　　　　　　Case 3
　　　　　　　　　　　　iR3 = iR2 - 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 4
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 - 1
　　　　　　　　End Select
　　　　　　Case iR4 > iR2 And iC4 <= iC2
　　　　　　　　Select Case i
　　　　　　　　　　Case 1
　　　　　　　　　　　　iR3 = iR2 + 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 2
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 - 1
　　　　　　　　　　Case 3
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 + 1
　　　　　　　　　　Case 4
　　　　　　　　　　　　iR3 = iR2 - 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　End Select
　　　　　　Case iR4 < iR2 And iC4 > iC2
　　　　　　　　Select Case i
　　　　　　　　　　Case 1
　　　　　　　　　　　　iR3 = iR2 - 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 2
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 + 1
　　　　　　　　　　Case 3
　　　　　　　　　　　　iR3 = iR2 + 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 4
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 - 1
　　　　　　　　End Select
　　　　　　Case iR4 = iR2 And iC4 > iC2
　　　　　　　　Select Case i
　　　　　　　　　　Case 1
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 + 1
　　　　　　　　　　Case 2
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 - 1
　　　　　　　　　　Case 3
　　　　　　　　　　　　iR3 = iR2 - 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 4
　　　　　　　　　　　　iR3 = iR2 + 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　End Select
　　　　　　Case iR4 < iR2 And iC4 <= iC2
　　　　　　　　Select Case i
　　　　　　　　　　Case 1
　　　　　　　　　　　　iR3 = iR2 - 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 2
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 - 1
　　　　　　　　　　Case 3
　　　　　　　　　　　　iR3 = iR2 + 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 4
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 + 1
　　　　　　　　End Select
　　　　　　Case iR4 = iR2 And iC4 <= iC2
　　　　　　　　Select Case i
　　　　　　　　　　Case 1
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 - 1
　　　　　　　　　　Case 2
　　　　　　　　　　　　iR3 = iR2
　　　　　　　　　　　　iC3 = iC2 + 1
　　　　　　　　　　Case 3
　　　　　　　　　　　　iR3 = iR2 - 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　　　Case 4
　　　　　　　　　　　　iR3 = iR2 + 1
　　　　　　　　　　　　iC3 = iC2
　　　　　　　　End Select
　　　　End Select
　　　　
　　　　If SuAry(1, 1) = "" Then
　　　　　　If (iR2 = 2 And iC2 = 1) Or _
　　　　　　　 (iR2 = 1 And iC2 = 2) Then
　　　　　　　　iR3 = 1
　　　　　　　　iC3 = 1
　　　　　　End If
　　　　End If
　　　　If SuAry(1, 10) = "" Then
　　　　　　If (iR2 = 2 And iC2 = 10) Or _
　　　　　　　 (iR2 = 1 And iC2 = 9) Then
　　　　　　　　iR3 = 1
　　　　　　　　iC3 = 10
　　　　　　End If
　　　　End If
　　　　If SuAry(10, 1) = "" Then
　　　　　　If (iR2 = 9 And iC2 = 1) Or _
　　　　　　　 (iR2 = 10 And iC2 = 2) Then
　　　　　　　　iR3 = 10
　　　　　　　　iC3 = 1
　　　　　　End If
　　　　End If
　　　　If SuAry(10, 10) = "" Then
　　　　　　If (iR2 = 9 And iC2 = 10) Or _
　　　　　　　 (iR2 = 10 And iC2 = 9) Then
　　　　　　　　iR3 = 10
　　　　　　　　iC3 = 10
　　　　　　End If
　　　　End If
　　　　
　　　　If iC3 >= 1 And iC3 <= 10 And iR3 >= 1 And iR3 <= 10 Then
　　　　　　If SuAry(iR3, iC3) = "" Then
　　　　　　　　If chkAdvance(iR3, iC3, SuAry(iR, iC)) = True Then
　　　　　　　　　　If chkClose(iR3, iC3, SuAry(iR, iC)) = True Then
　　　　　　　　　　　　If chkRout(iR, iC) = True Then
　　　　　　　　　　　　　　tryCnt = tryCnt + 1
　　　　　　　　　　　　　　Call dispCell(True, iR3, iC3, SuAry(iR, iC) & "-" & tryCnt)
　　　　　　　　　　　　　　rtn = getAdvance(iR, iC, iR3, iC3, tryCnt)
　　　　　　　　　　　　　　Select Case rtn
　　　　　　　　　　　　　　　　Case "完了"
　　　　　　　　　　　　　　　　　　getAdvance = "完了"
　　　　　　　　　　　　　　　　　　Exit Function
　　　　　　　　　　　　　　End Select
　　　　　　　　　　　　　　If Not IsNumeric(SuAry(iR3, iC3)) Then
　　　　　　　　　　　　　　　　tryCnt = tryCnt - 1
　　　　　　　　　　　　　　　　Call dispCell(True, iR3, iC3, "")
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next
　　If IsNumeric(SuAry(iR2, iC2)) Then
　　　　getAdvance = "破綻"
　　Else
　　　　tryCnt = tryCnt - 1
　　　　Call dispCell(True, iR2, iC2, "")
　　　　getAdvance = "別ルート探索"
　　End If
End Function

Private Function chkAdvance(ByVal iR As Integer, ByVal iC As Integer, ByVal i As Integer) As Boolean
　　Dim cnt As Integer
　　cnt = 0
　　If iR <> 1 And iC <> 1 Then
　　　　If InStr(SuAry(iR - 1, iC - 1), i & "-") > 0 Or SuAry(iR - 1, iC - 1) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If InStr(SuAry(iR - 1, iC), i & "-") > 0 Or SuAry(iR - 1, iC) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If InStr(SuAry(iR, iC - 1), i & "-") > 0 Or SuAry(iR, iC - 1) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If cnt >= 3 Then
　　　　　　chkAdvance = False
　　　　　　Exit Function
　　　　End If
　　End If
　　
　　cnt = 0
　　If iR <> 10 And iC <> 1 Then
　　　　If InStr(SuAry(iR + 1, iC - 1), i & "-") > 0 Or SuAry(iR + 1, iC - 1) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If InStr(SuAry(iR + 1, iC), i & "-") > 0 Or SuAry(iR + 1, iC) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If InStr(SuAry(iR, iC - 1), i & "-") > 0 Or SuAry(iR, iC - 1) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If cnt >= 3 Then
　　　　　　chkAdvance = False
　　　　　　Exit Function
　　　　End If
　　End If
　　
　　cnt = 0
　　If iR <> 1 And iC <> 10 Then
　　　　If InStr(SuAry(iR - 1, iC + 1), i & "-") > 0 Or SuAry(iR - 1, iC + 1) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If InStr(SuAry(iR - 1, iC), i & "-") > 0 Or SuAry(iR - 1, iC) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If InStr(SuAry(iR, iC + 1), i & "-") > 0 Or SuAry(iR, iC + 1) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If cnt >= 3 Then
　　　　　　chkAdvance = False
　　　　　　Exit Function
　　　　End If
　　End If
　　
　　cnt = 0
　　If iR <> 10 And iC <> 10 Then
　　　　If InStr(SuAry(iR + 1, iC + 1), i & "-") > 0 Or SuAry(iR + 1, iC + 1) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If InStr(SuAry(iR + 1, iC), i & "-") > 0 Or SuAry(iR + 1, iC) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If InStr(SuAry(iR, iC + 1), i & "-") > 0 Or SuAry(iR, iC + 1) = CStr(i) Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If cnt >= 3 Then
　　　　　　chkAdvance = False
　　　　　　Exit Function
　　　　End If
　　End If
　　chkAdvance = True
End Function

Private Sub dispCell(ByVal blnDisp As Boolean, _
　　　　　　　　　　 Optional ByVal iR As Integer = 0, Optional ByVal iC As Integer = 0, _
　　　　　　　　　　 Optional ByVal dispStr As String = "")
　　Dim i As Integer
　　Dim j As Integer
　　Dim bR As Integer
　　Dim bC As Integer
　　Dim aR As Integer
　　Dim aC As Integer
　　Dim SuAry3(1 To 10, 1 To 10) As String

　　If iR <> 0 And iC <> 0 Then
　　　　SuAry(iR, iC) = dispStr
　　End If
　　If blnDisp = False Then
　　　　Exit Sub
　　End If
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　If IsNumeric(SuAry(i, j)) Then
　　　　　　　　SuAry3(i, j) = SuAry(i, j)
　　　　　　　　If chkEnd(i, j) = True Then
　　　　　　　　　　SuAry2(i, j) = SuAry(i, j) & "-99"
　　　　　　　　Else
　　　　　　　　　　SuAry2(i, j) = SuAry(i, j) & "-0"
　　　　　　　　End If
　　　　　　Else
　　　　　　　　SuAry2(i, j) = SuAry(i, j)
　　　　　　End If
　　　　Next
　　Next
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　Call getBeforeCell(i, j, bR, bC)
　　　　　　Call getAfterCell(i, j, aR, aC)
　　　　　　If bR <> 0 And bC <> 0 Then
　　　　　　　　If aR = 0 And aC = 0 Then
　　　　　　　　　　SuAry3(i, j) = "◆"
　　　　　　　　Else
　　　　　　　　　　If (aR > i And i > bR) Or _
　　　　　　　　　　　 (aR < i And i < bR) Then
　　　　　　　　　　　　SuAry3(i, j) = "┃"
　　　　　　　　　　End If
　　　　　　　　　　If (aC > j And j > bC) Or _
　　　　　　　　　　　 (aC < j And j < bC) Then
　　　　　　　　　　　　SuAry3(i, j) = "━"
　　　　　　　　　　End If
　　　　　　　　　　If (aC > j And i < bR) Or _
　　　　　　　　　　　 (aR > i And j < bC) Then
　　　　　　　　　　　　SuAry3(i, j) = "┏"
　　　　　　　　　　End If
　　　　　　　　　　If (aC < j And i < bR) Or _
　　　　　　　　　　　 (aR > i And j > bC) Then
　　　　　　　　　　　　SuAry3(i, j) = "┓"
　　　　　　　　　　End If
　　　　　　　　　　If (aC > j And i > bR) Or _
　　　　　　　　　　　 (aR < i And j < bC) Then
　　　　　　　　　　　　SuAry3(i, j) = "┗"
　　　　　　　　　　End If
　　　　　　　　　　If (aC < j And i > bR) Or _
　　　　　　　　　　　 (aR < i And j > bC) Then
　　　　　　　　　　　　SuAry3(i, j) = "┛"
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Next
　　DispRange = SuAry3
　　DoEvents
End Sub

Private Sub getBeforeCell(ByVal iR As Integer, ByVal iC As Integer, ByRef iR2 As Integer, ByRef iC2 As Integer)
　　Dim i As Integer
　　Dim j As Integer
　　Dim n1 As Integer
　　Dim n2 As Integer
　　Dim strSu As String
　　iR2 = 0
　　iC2 = 2
　　If SuAry2(iR, iC) = "" Then
　　　　Exit Sub
　　End If
　　n1 = Split(SuAry2(iR, iC), "-")(0)
　　n2 = Split(SuAry2(iR, iC), "-")(1)
　　If n2 = "0" Or n2 = "99" Then
　　　　Exit Sub
　　End If
　　n2 = n2 - 1
　　strSu = n1 & "-" & n2
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　If SuAry2(i, j) = strSu Then
　　　　　　　　iR2 = i
　　　　　　　　iC2 = j
　　　　　　　　Exit Sub
　　　　　　End If
　　　　Next
　　Next
End Sub

Private Sub getAfterCell(ByVal iR As Integer, ByVal iC As Integer, ByRef iR2 As Integer, ByRef iC2 As Integer)
　　Dim i As Integer
　　Dim j As Integer
　　Dim n1 As Integer
　　Dim n2 As Integer
　　Dim strSu As String
　　iR2 = 0
　　iC2 = 2
　　If SuAry2(iR, iC) = "" Then
　　　　Exit Sub
　　End If
　　n1 = Split(SuAry2(iR, iC), "-")(0)
　　n2 = Split(SuAry2(iR, iC), "-")(1)
　　If n2 = "0" Or n2 = "99" Then
　　　　Exit Sub
　　End If
　　n2 = n2 + 1
　　strSu = n1 & "-" & n2
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　If SuAry(i, j) = strSu Then
　　　　　　　　iR2 = i
　　　　　　　　iC2 = j
　　　　　　　　Exit Sub
　　　　　　End If
　　　　Next
　　Next
　　strSu = n1 & "-99"
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　If SuAry2(i, j) = strSu Then
　　　　　　　　If (iR = i - 1 And iC = j) Or _
　　　　　　　　　 (iR = i And iC = j + 1) Or _
　　　　　　　　　 (iR = i + 1 And iC = j) Or _
　　　　　　　　　 (iR = i And iC = j - 1) Then
　　　　　　　　　　iR2 = i
　　　　　　　　　　iC2 = j
　　　　　　　　Else
　　　　　　　　　　iR2 = 0
　　　　　　　　　　iC2 = 0
　　　　　　　　End If
　　　　　　　　Exit Sub
　　　　　　End If
　　　　Next
　　Next
End Sub

Private Function getStart(ByRef iR As Integer, ByRef iC As Integer) As Boolean
　　iC = iC + 1
　　If RowColAjust(iR, iC) = False Then
　　　　getStart = False
　　　　Exit Function
　　End If
　　Do
　　　　If IsNumeric(SuAry(iR, iC)) Then
　　　　　　If chkEnd(iR, iC) <> True Then
　　　　　　　　getStart = True
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　　　iC = iC + 1
　　　　If RowColAjust(iR, iC) = False Then
　　　　　　getStart = False
　　　　　　Exit Function
　　　　End If
　　Loop
End Function

Private Function RowColAjust(ByRef iR As Integer, ByRef iC As Integer) As Boolean
　　If iC > 10 Then
　　　　iR = iR + 1
　　　　iC = 1
　　End If
　　If iR > 10 Then
　　　　RowColAjust = False
　　　　Exit Function
　　End If
　　RowColAjust = True
End Function

Private Function chkEnd(ByVal iR As Integer, ByVal iC As Integer) As Boolean
　　Dim iR2 As Integer
　　Dim iC2 As Integer
　　Call getEnd(iR2, iC2, SuAry(iR, iC))
　　If iR2 = iR And iC2 = iC Then
　　　　chkEnd = True
　　Else
　　　　chkEnd = False
　　End If
End Function

Private Sub getEnd(ByRef iR2 As Integer, ByRef iC2 As Integer, ByVal i As String)
　　iR2 = 10
　　iC2 = 10
　　Do
　　　　If SuAry(iR2, iC2) = i Then
　　　　　　Exit Sub
　　　　End If
　　　　iC2 = iC2 - 1
　　　　If iC2 < 1 Then
　　　　　　iR2 = iR2 - 1
　　　　　　iC2 = 10
　　　　End If
　　　　If iR2 < 1 Then
　　　　　　Exit Sub
　　　　End If
　　Loop
End Sub

Private Function chkRout(ByVal iR1 As Integer, ByVal iC1 As Integer) As Boolean
　　Dim iR2 As Integer
　　Dim iC2 As Integer
　　Dim iR3 As Integer
　　Dim iC3 As Integer
　　Dim i As Integer
　　Dim j As Integer
　　chkRout = True
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　SuAry2(i, j) = SuAry(i, j)
　　　　Next
　　Next
　　If getStart(iR1, iC1) = False Then
　　　　chkRout = True
　　　　Exit Function
　　End If
　　Call getEnd(iR2, iC2, SuAry(iR1, iC1))
　　
　　If chkRout2(iR1, iC1, iR2, iC2) = False Then
　　　　chkRout = False
　　End If
　　If chkRout(iR1, iC1) = False Then
　　　　chkRout = False
　　End If
End Function

Private Function chkRout2(ByVal iR1 As Integer, ByVal iC1 As Integer, ByVal iR2 As Integer, ByVal iC2 As Integer) As Boolean
　　Dim i As Integer
　　Dim iR3 As Integer
　　Dim iC3 As Integer
　　Select Case True
　　　　Case iR1 = iR2 - 1 And iC1 = iC2, _
　　　　　　 iR1 = iR2 And iC1 = iC2 + 1, _
　　　　　　 iR1 = iR2 + 1 And iC1 = iC2, _
　　　　　　 iR1 = iR2 And iC1 = iC2 - 1
　　　　　　chkRout2 = True
　　　　　　Exit Function
　　End Select
　　For i = 1 To 4
　　　　Select Case i
　　　　　　Case 1
　　　　　　　　iR3 = iR2 + 1
　　　　　　　　iC3 = iC2
　　　　　　Case 2
　　　　　　　　iR3 = iR2
　　　　　　　　iC3 = iC2 + 1
　　　　　　Case 3
　　　　　　　　iR3 = iR2 - 1
　　　　　　　　iC3 = iC2
　　　　　　Case 4
　　　　　　　　iR3 = iR2
　　　　　　　　iC3 = iC2 - 1
　　　　End Select
　　　　If iC3 >= 1 And iC3 <= 10 And iR3 >= 1 And iR3 <= 10 Then
　　　　　　If SuAry2(iR3, iC3) = "" Then
　　　　　　　　SuAry2(iR3, iC3) = "●"
　　　　　　　　If chkRout2(iR1, iC1, iR3, iC3) = True Then
　　　　　　　　　　chkRout2 = True
　　　　　　　　　　Exit Function
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next
　　chkRout2 = False
End Function

Private Function chkClose(ByVal iR1 As Integer, ByVal iC1 As Integer, ByVal iNo As Integer) As Boolean
　　Dim iR2 As Integer
　　Dim iC2 As Integer
　　Dim cnt As Integer
　　Dim i As Integer
　　Dim j As Integer
　　chkClose = True
　　
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　SuAry2(i, j) = SuAry(i, j)
　　　　Next
　　Next
　　SuAry2(iR1, iC1) = "●"
　　cnt = 0
　　If iR1 > 1 Then
　　　　If SuAry2(iR1 - 1, iC1) = "" Then
　　　　　　If chkClose3(iR1 - 1, iC1, iNo) = False Then
　　　　　　　　chkClose = False
　　　　　　　　Exit Function
　　　　　　End If
　　　　　　Call chkClose2(iR1 - 1, iC1, cnt, iNo)
　　　　　　If cnt <= 1 Then
　　　　　　　　chkClose = False
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　End If
　　
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　SuAry2(i, j) = SuAry(i, j)
　　　　Next
　　Next
　　SuAry2(iR1, iC1) = "●"
　　cnt = 0
　　If iR1 < 10 Then
　　　　If SuAry2(iR1 + 1, iC1) = "" Then
　　　　　　If chkClose3(iR1 + 1, iC1, iNo) = False Then
　　　　　　　　chkClose = False
　　　　　　　　Exit Function
　　　　　　End If
　　　　　　Call chkClose2(iR1 + 1, iC1, cnt, iNo)
　　　　　　If cnt <= 1 Then
　　　　　　　　chkClose = False
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　End If
　　
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　SuAry2(i, j) = SuAry(i, j)
　　　　Next
　　Next
　　SuAry2(iR1, iC1) = "●"
　　cnt = 0
　　If iC1 > 1 Then
　　　　If SuAry2(iR1, iC1 - 1) = "" Then
　　　　　　If chkClose3(iR1, iC1 - 1, iNo) = False Then
　　　　　　　　chkClose = False
　　　　　　　　Exit Function
　　　　　　End If
　　　　　　Call chkClose2(iR1, iC1 - 1, cnt, iNo)
　　　　　　If cnt <= 1 Then
　　　　　　　　chkClose = False
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　End If
　　
　　For i = 1 To 10
　　　　For j = 1 To 10
　　　　　　SuAry2(i, j) = SuAry(i, j)
　　　　Next
　　Next
　　SuAry2(iR1, iC1) = "●"
　　cnt = 0
　　If iC1 < 10 Then
　　　　If SuAry2(iR1, iC1 + 1) = "" Then
　　　　　　If chkClose3(iR1, iC1 + 1, iNo) = False Then
　　　　　　　　chkClose = False
　　　　　　　　Exit Function
　　　　　　End If
　　　　　　Call chkClose2(iR1, iC1 + 1, cnt, iNo)
　　　　　　If cnt <= 1 Then
　　　　　　　　chkClose = False
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　End If
End Function

Private Sub chkClose2(ByVal iR1 As Integer, ByVal iC1 As Integer, ByRef cnt As Integer, ByVal iNo As Integer)
　　Dim i As Integer
　　Dim iR3 As Integer
　　Dim iC3 As Integer
　　If cnt >= 2 Then
　　　　Exit Sub
　　End If
　　For i = 1 To 4
　　　　Select Case i
　　　　　　Case 1
　　　　　　　　iR3 = iR1 + 1
　　　　　　　　iC3 = iC1
　　　　　　Case 2
　　　　　　　　iR3 = iR1
　　　　　　　　iC3 = iC1 + 1
　　　　　　Case 3
　　　　　　　　iR3 = iR1 - 1
　　　　　　　　iC3 = iC1
　　　　　　Case 4
　　　　　　　　iR3 = iR1
　　　　　　　　iC3 = iC1 - 1
　　　　End Select
　　　　If iC3 >= 1 And iC3 <= 10 And iR3 >= 1 And iR3 <= 10 Then
　　　　　　If SuAry2(iR3, iC3) = "" Then
　　　　　　　　SuAry2(iR3, iC3) = "●"
　　　　　　　　Call chkClose2(iR3, iC3, cnt, iNo)
　　　　　　Else
　　　　　　　　If SuAry2(iR3, iC3) = CStr(iNo) Then
　　　　　　　　　　cnt = 2
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　If IsNumeric(SuAry2(iR3, iC3)) Then
　　　　　　　　　　SuAry2(iR3, iC3) = "●"
　　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　If cnt >= 2 Then
　　　　　　　　　　　　Exit Sub
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next
End Sub

Private Function chkClose3(ByVal iR1 As Integer, ByVal iC1 As Integer, ByVal iNo As Integer) As Boolean
　　Dim cnt As Integer
　　Dim i As Integer
　　Dim j As Integer
　　chkClose3 = True
　　If (iR1 = 1 Or iR1 = 10) And (iC1 = 1 Or iC1 = 10) Then
　　　　chkClose3 = True
　　　　Exit Function
　　End If
　　cnt = 0
　　If iR1 > 1 Then
　　　　If SuAry2(iR1 - 1, iC1) = "" Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If IsNumeric(SuAry2(iR1 - 1, iC1)) Then
　　　　　　chkClose3 = True
　　　　　　Exit Function
　　　　End If
　　　　If SuAry2(iR1 - 1, iC1) <> "●" And InStr(SuAry2(iR1 - 1, iC1), "-") > 0 Then
　　　　　　If Split(SuAry2(iR1 - 1, iC1), "-")(0) <> CStr(iNo) Then
　　　　　　　　chkClose3 = True
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　End If
　　
　　If iR1 < 10 Then
　　　　If SuAry2(iR1 + 1, iC1) = "" Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If IsNumeric(SuAry2(iR1 + 1, iC1)) Then
　　　　　　chkClose3 = True
　　　　　　Exit Function
　　　　End If
　　　　If SuAry2(iR1 + 1, iC1) <> "●" And InStr(SuAry2(iR1 + 1, iC1), "-") > 0 Then
　　　　　　If Split(SuAry2(iR1 + 1, iC1), "-")(0) <> CStr(iNo) Then
　　　　　　　　chkClose3 = True
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　End If
　　
　　If iC1 > 1 Then
　　　　If SuAry2(iR1, iC1 - 1) = "" Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If IsNumeric(SuAry2(iR1, iC1 - 1)) Then
　　　　　　chkClose3 = True
　　　　　　Exit Function
　　　　End If
　　　　If SuAry2(iR1, iC1 - 1) <> "●" And InStr(SuAry2(iR1, iC1 - 1), "-") > 0 Then
　　　　　　If Split(SuAry2(iR1, iC1 - 1), "-")(0) <> CStr(iNo) Then
　　　　　　　　chkClose3 = True
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　End If
　　
　　If iC1 < 10 Then
　　　　If SuAry2(iR1, iC1 + 1) = "" Then
　　　　　　cnt = cnt + 1
　　　　End If
　　　　If IsNumeric(SuAry2(iR1, iC1 + 1)) Then
　　　　　　chkClose3 = True
　　　　　　Exit Function
　　　　End If
　　　　If SuAry2(iR1, iC1 + 1) <> "●" And InStr(SuAry2(iR1, iC1 + 1), "-") > 0 Then
　　　　　　If Split(SuAry2(iR1, iC1 + 1), "-")(0) <> CStr(iNo) Then
　　　　　　　　chkClose3 = True
　　　　　　　　Exit Function
　　　　　　End If
　　　　End If
　　End If
　　If cnt <= 1 Then
　　　　chkClose3 = False
　　End If
End Function



ここは特に説明の必要はないでしょう。


シートへの表示のためのロジックが結構面倒でしたね、

処理時間も、約3分半くらいになってます、まあ許容範囲内でしょうか。

いやー、作り始めたときは、なんとかなるだろうと思っていたのですが・・・

途中挫折しかけました、いや、挫折しました。

少し間をおいてから再挑戦したりを2回ほど繰り返して、なんとかたどり着けました。

完全に趣味の範囲ですし、これが出来たからといって、何だということもありません。

VBAの腕試しと、あたまの体操、そして問題解決能力を磨く

まあ、そんなところでしょうか。

時間のある方は、いろいろなパズルを解くVBA作りに挑戦してみてください。

最後に、10×10以外でも解けるようにRange範囲指定を可変にし、

汎用で使えるように修正したものを紹介しておきます。

№8へ続きます。


ナンバーリンク(パズル)を解くVBAに挑戦 ： №1 №2 №3 №4 №5 №6 №7 №8



※ナンバーリンクを解くVBAのパフォーマンス改善
「ナンバーリンク(パズル)を解くVBAに挑戦」で作成したVBAでナンバーリンクを解く事には成功しました、しかし、10×10なら数分で解けるものの、10×18でやったところ、4時間半もかかってしまいました。12×12では、待ちきれずに途中で止めてしまいました。
こちらの最終完成版のダウンロード


同じテーマ「マクロVBAサンプル集」の記事

アメブロの記事本文をVBAでバックアップする№1
数独（ナンプレ）を解くVBAに挑戦№1
数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1
ナンバーリンク(パズル)を解くVBAに挑戦№1
ナンバーリンクを解くVBAのパフォーマンス改善№1
オセロを作りながらマクロVBAを学ぼう
他ブックへのリンクエラーを探し解除
Excelシートの複雑な計算式を解析するVBA
Excel将棋：マクロVBAの学習用(№1)
Excel囲碁：万波奈穂先生に捧ぐ
Excel囲碁：再起動後も続けて打てるように改造


新着記事NEW ・・・新着記事一覧を見る

PropertyのSetはLetでも良い｜VBA技術解説(2021-03-31)
エクセル麻雀ミニゲーム｜VBAサンプル集(2021-03-09)
VBA100本ノック 100本目：WEBから100本ノックのリストを取得｜VBA練習問題(2021-03-03)
VBA100本ノック 魔球編：2桁の最小公倍数｜VBA練習問題(2021-02-02)
Select Caseでの短絡評価（ショートサーキット）の使い方｜VBA技術解説(2021-01-03)
VBA100本ノック 迷宮編：巡回セル問題｜VBA練習問題(2020-12-31)
VBA100本ノック 魔球編：閉領域の塗り潰し｜VBA練習問題(2020-12-16)
VBA100本ノック 魔球編：組み合わせ問題｜VBA練習問題(2020-12-02)
将棋とプログラミングについて～そこには型がある～｜エクセル雑感(2020-11-22)
VBA100本ノック 1本目：セルのコピー｜VBA練習問題(2020-10-19)


アクセスランキング ・・・ ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.マクロって何？VBAって何？｜VBA入門
5.Excelショートカットキー一覧｜Excelリファレンス
6.繰り返し処理（For Next)｜VBA入門
7.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
8.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
9.セルに文字を入れるとは（Range,Value）｜VBA入門
10.とにかく書いてみよう（Sub,End Sub）｜VBA入門



このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
本文下部へ
同じテーマの記事
新着記事
アクセスランク


↑