ExcelマクロVBAサンプル集 | ナンバーリンク(パズル)を解くVBAに挑戦2 | Excelマクロの実用サンプル、エクセルVBA集と解説



最終更新日:2014-11-26

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

ナンバーリンクというパズルをエクセルVBAで解くために作成するプロシージャーになります。



作成するプロシージャー
main
入り口となるメインのプロシードャー
getStart
開始位置を取得するプロシージャー
getEnd
終了位置を取得するプロシージャー
chkEnd
指定位置が終了位置かを判断するプロシージャー
RowColAjust
行・列の数値を指定範囲内に収めつつ、次の位置へ進むためのプロシージャー
getAdvance
進む先を決めるプロシージャー、中核となるプロシージャーです。
dispCell
配列をシートに表示するプロシージャー


とにかく、コードです。

Option Explicit

Private SuAry(1 To 10, 1 To 10) As String

Sub main()
  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
  Range("B2:K11").Value = SuAry
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 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 iC3 >= 1 And iC3 <= 10 And iR3 >= 1 And iR3 <= 10 Then
      If SuAry(iR3, iC3) = "" 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
  Next
  If IsNumeric(SuAry(iR2, iC2)) Then
    getAdvance = "破綻"
  Else
    tryCnt = tryCnt - 1
    Call dispCell(True, iR2, iC2, "")
    getAdvance = "別ルート探索"
  End If
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 = 1 And iC = 9 And dispStr = "1-1" Then
    DoEvents
  End If
  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


表示は、スタートの数字に"-1","-2"のように連番を下につけて進みます。

行き先が無くなれば、元に戻って別の道を探すといった具合になります。

getAdvance

の中ごろの

For i = 1 To 4
・・・
Next

この部分が、コードの長くなっていて、もう少しすっきり出来そうですが、

こういうとき、中核のロジックは、

多少長くなっても、わかりやすくしておいた方が後々楽だと思います。

この部分こそ、次に右に進むか左に進むか、上か下かを決定する部分になります。

赤字の、

getAdvance

ここが再起呼び出しになります。

パズルのような、無限通りともいえる手順が存在する場合には、再起呼び出しは必須になります。

結局は、ここがかけるかどうかが問題で、再起呼び出しが書けないと、プログラムで解くことは不可能になります。

上記のプログラムは実行してみてもらえれば直ぐにわかりますが、

とても、正解にたどり着けるとは思えません。

バグ云々は別にして、正解にたどり着くのに何時間かかるか、そもそもたどり着けるのか・・・

動きを見れば一目瞭然です。

人間なら絶対に進まない場所に進んでいき、行き場所をなくしたり、

進んだと思ったら、戻ってきてしまったりと、まったく解く気のない動きです(笑)

それで、進む先を自分で見つけて、進めなくなったら、元に戻って別のルートを探すという、

このパズルの本質部分は確実に出来上がりました。

次回以降、無駄な動きを減らして、解にたどり着けるようにしていきます。

3へ続きます。


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




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

ナンバーリンクを解くVBAのパフォーマンス改善3
アメブロの記事本文をVBAでバックアップする6
数独(ナンプレ)を解くVBAに挑戦5
数独(ナンプレ)を解くアルゴリズムの要点とパフォーマンスの検証4

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

空白セルを正しく判定する方法2|ExcelマクロVBA技術解説(5月6日)
フルパスをディレクトリ、ファイル名、拡張子に分ける|ExcelマクロVBA技術解説(4月15日)
テキストボックスの各種イベント|Excelユーザーフォーム入門(4月9日)
フォルダ(サブフォルダも全て)削除する、Optionでファイルのみ削除|ExcelマクロVBAサンプル集(4月4日)
最後の空白(や指定文字)以降の文字を取り出す|エクセル関数超技(3月26日)
先頭の数値、最後の数値を取り出す|エクセル関数超技(3月26日)
Excelファイルを開かずにシート名をチェック|ExcelマクロVBAサンプル集(3月23日)
数式の参照しているセルを取得する|ExcelマクロVBAサンプル集(3月18日)
CSVの読み込み方法(改の改)|ExcelマクロVBAサンプル集(3月17日)
変数とプロシージャーの命名について|ExcelマクロVBA技術解説(2月12日)

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

1.最終行の取得(End,Rows.Count)|ExcelマクロVBA入門
2.ひらがな⇔カタカナの変換|エクセル基本操作
3.RangeとCellsの使い方|ExcelマクロVBA入門
4.Range以外の指定方法(Cells,Rows,Columns)|ExcelマクロVBA入門
5.徹底解説(VLOOKUP,MATCH,INDEX,OFFSET)|エクセル関数超技
6.変数とデータ型(Dim)|ExcelマクロVBA入門
7.セルの参照範囲を可変にする(OFFSET,COUNTA,MATCH)|エクセル関数超技
8.セルのコピー&値の貼り付け(PasteSpecial)|ExcelマクロVBA入門
9.CSVの読み込み方法|ExcelマクロVBAサンプル集
10.定数と型宣言文字(Const)|ExcelマクロVBA入門



  • >
  • >
  • >
  • ナンバーリンク(パズル)を解くVBAに挑戦2

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


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




    ↑ PAGE TOP