ボンバーパズル

図1.

図1．は毎日新聞に掲載されたパズルです。表中の数字は 斜め方向を含む隣接マスに存在する爆弾の数で、これを根拠に位置を求めます。図1．右は解答です。このパズルには手筋があまりありませんが、図で、b8:c8, h3:i3 セルのように外周枠に接し １〜４ の同じ数字が並んでいる場合 m7:m9, p2:p4 には x が確定します。基本的には例えば将棋で何手か先まで読むような感じで進めます。縦横の最大のマス数は２５にしています。

次の例題はかなり手強いですが、コンピューターの強みで解けます。難問では Give up します。

なお、問題範囲全体を枠線で囲む必要があり　シートの A1 セルから始めた場合には自動的に、行および列が挿入されます。エラーを回避するためです。

例題

121 1
3 33
1132 2
33 3
42 32
434 3
3 22
343 32
11 3
112 2

Excel VBA


Sub bomber()
Dim Rng As Range                              '---[ Bomber Puzzle Ver 4.1 ]---
   Call SelStart(w):  Set c0 = Range(w)
         If c0.Row = 1 Or c0.Column = 1 Then c0.EntireRow.Insert: c0.EntireColumn.Insert
      For y = 1 To 25: If c0.Cells(y + 1, 1).Borders(xlLeft).LineStyle <> 1 Then Exit For
      Next
      For x = 1 To 25: If c0.Cells(1, x + 1).Borders(xlTop).LineStyle <> 1 Then Exit For
      Next:                       Set Rng = Range(c0, c0.Cells(y, x))   'Rng　　問題範囲
         With Rng: .HorizontalAlignment = xlCenter: .ColumnWidth = 3.4: .RowHeight = 22.6
                  .Borders.Weight = 2: .BorderAround Weight:=xlThick:          End With
   Call Init(Rng):         a = MsgBox("Start?", vbYesNo):          If a = vbNo Then End
            Rng.SpecialCells(xlCellTypeBlanks).Font.Size = 1
  Do:     Erc = 0
     For Each c In Rng.SpecialCells(xlCellTypeBlanks):  Arr = Rng:   ok = False
          c.Value = "●": Call Exct(Rng, Er):   Rng = Arr
       If Er = True Then Er = False: ok = True: Erc = Erc + 1: c.Value = "×"
          If ok = True Then Else Arr = Rng: c.Value = "×": Call Exct(Rng, Er): Rng = Arr
       If Er = True Then Er = False: Erc = Erc + 1: c.Value = "●"
     Next
  Loop While Erc > 0 And WorksheetFunction.CountBlank(Rng) > 0
            Rng.Font.Size = 11:  MsgBox "Give UP": Call Init(Rng)
End Sub
Sub SelStart(w)
 For I = 1 To 8: For j = 1 To 8: Set b = Cells(j, I).Borders(xlEdgeLeft)
      If b.LineStyle = 1 Then w = Cells(j, I).Address: Exit Sub        ' 開始セル番地取得
 Next: Next:           MsgBox "問題範囲の外周枠を線引きする必要があります。":   End
End Sub
Sub Init(Rng)
   For Each c In Rng:            If IsNumeric(c) = False Then c.Value = ""
   Next
End Sub
Sub Exct(Rng, Er)
Do:   ok = "":      For Each c In Rng
    If c.Value Like "[0-8]" Then
         Set c1 = c.Offset(-1, -1): Set c2 = c.Range("b2")
          n = c.Value:  Set Rn = Intersect(Range(c1, c2), Rng)
          bl = WorksheetFunction.CountBlank(Rn): bm = WorksheetFunction.CountIf(Rn, "●")
       If n = 0 Then Rn.Replace What:="", Replacement:="×"
       If bl > 0 And bl + bm = n Then Rn.Replace What:="", Replacement:="●":   ok = True
       If bl > 0 And bm = n Then Rn.Replace What:="", Replacement:="×":        ok = True
       If bm > n Or bl + bm < n Then Er = True: Exit Sub
     End If:        Next
 Loop While ok = True
If WorksheetFunction.CountBlank(Rng) = 0 Then Rng.Font.Size = 11: MsgBox "Completed": End
End Sub

このサイトで扱った項目