ナンバーリンク(パズル)を解くVBAに挑戦№6
さーて、後はどこが無駄なのか、これを探すのが大変です。
chkClose3
小さな袋小路かどうかの判断
chkClose3は、chkCloseから呼び出します。
Option Explicit
Private SuAry(1 To 10, 1 To 10) As String
Private SuAry2(1 To 10, 1 To 10) As String
Sub main()
Debug.Print Now()
Dim iR As Integer
Dim iC As Integer
For iR = 1 To 10
For iC = 1 To 10
With Cells(iR + 1, iC + 1)
If .Value = "" Or Not IsNumeric(.Value) Then
.Value = ""
.Font.Size = 9
.Font.Bold = False
.NumberFormat = "@"
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 = "")
If iR <> 0 And iC <> 0 Then
SuAry(iR, iC) = dispStr
End If
If blnDisp = True Then
Range("B2:K11").Value = SuAry
DoEvents
End If
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
一気に早くなりました。
ナンバーリンク(パズル)を解くVBAに挑戦 ： №1 №2 №3 №4 №5 №6 №7 №8
「ナンバーリンク(パズル)を解く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 ・・・新着記事一覧を見る
TRIMRANGE関数（セル範囲をトリム：端の空白セルを除外）｜エクセル入門(2024-08-30)
正規表現関数（REGEXTEST,REGEXREPLACE,REGEXEXTRACT）｜エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない｜エクセル雑感(2024-04-11)
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.繰り返し処理（For Next)｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.マクロとは？VBAとは？VBAでできること｜VBA入門
- ホーム
- マクロVBA応用編
- マクロVBAサンプル集
- ナンバーリンク(パズル)を解くVBAに挑戦№6
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。