VBA100本ノック 魔球編:閉領域の塗り潰し
四方を罫線で囲まれている範囲内のセルを塗りつぶす問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
出題
シート内のセルが四辺の罫線(線種は問わず)で完全に塞がれている閉じた範囲内にある場合、罫線で閉じられたセル範囲を黄色(好きな色)で塗りつぶしてください。
シートの端も罫線があるか無いかで判定してください。
※閉じられた範囲とは画像の黄色部分になります。


まあ、まだかろうじてボケてはいないようです口を開けて冷や汗をかいた笑顔
妻からは完全にボケ爺さん扱いされていますけど号泣



頂いた回答
解答
4方向再帰していく方法の2通り作成しました。
4方向再帰は範囲が広いと、スタック領域が不足してしまいます。
結局、囲碁で相手の石を囲んで取るアルゴリズムをほとんどそのまま使ったかんじになりました。
解答VBAコード
Sub main()
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Cells.Interior.Color = xlNone
Dim ary() As Boolean
With ws.UsedRange
If .CountLarge >= 10 ^ 8 Then MsgBox "ムリ!待てない!": Exit Sub
ReDim ary(0 To .Item(.Count).Row + 1, 0 To .Item(.Count).Column + 1)
End With
Call setAroundFlg(ary)
Dim s1 As Long, e1 As Long, s2 As Long, e2 As Long, p As Long
s1 = LBound(ary, 1) + 1: e1 = UBound(ary, 1) - 1
s2 = LBound(ary, 2) + 1: e2 = UBound(ary, 2) - 1
p = 1
Dim i As Long, j As Long, flg As Boolean
Do
flg = False
For i = s1 To e1 Step p
For j = s2 To e2 Step p
If Not ary(i, j) Then
If BordersNone(ws.Cells(i, j), ary, i, j) Then
ary(i, j) = True
flg = True
End If
End If
Next
Next
If Not flg Then Exit Do
s1 = s1 Xor e1: e1 = s1 Xor e1: s1 = s1 Xor e1
s2 = s2 Xor e2: e2 = s2 Xor e2: s2 = s2 Xor e2
p = p * -1
Loop
Call paintClosed(ws, ary)
End Sub
Sub setAroundFlg(ary() As Boolean)
Dim i As Long, j As Long
For i = LBound(ary, 1) To UBound(ary, 1)
ary(i, 0) = True: ary(i, UBound(ary, 2)) = True
Next
For j = LBound(ary, 2) To UBound(ary, 2)
ary(0, j) = True: ary(UBound(ary, 1), j) = True
Next
End Sub
Function BordersNone(ByVal aRng As Range, ary() As Boolean, i As Long, j As Long) As Boolean
BordersNone = True
If aRng.Borders(xlEdgeTop).LineStyle = xlNone And ary(i - 1, j) Then Exit Function
If aRng.Borders(xlEdgeBottom).LineStyle = xlNone And ary(i + 1, j) Then Exit Function
If aRng.Borders(xlEdgeLeft).LineStyle = xlNone And ary(i, j - 1) Then Exit Function
If aRng.Borders(xlEdgeRight).LineStyle = xlNone And ary(i, j + 1) Then Exit Function
BordersNone = False
End Function
Sub paintClosed(ws As Worksheet, ary() As Boolean)
Dim i As Long, j As Long, uRng As Range
For i = LBound(ary, 1) + 1 To UBound(ary, 1) - 1
For j = LBound(ary, 2) + 1 To UBound(ary, 2) - 1
If Not ary(i, j) Then
If uRng Is Nothing Then
Set uRng = ws.Cells(i, j)
Else
Set uRng = Union(uRng, ws.Cells(i, j))
End If
End If
Next
Next
If Not uRng Is Nothing Then uRng.Interior.Color = vbYellow
End Sub
実際のセル範囲より上下左右に1広げた配列を用意し、
その外枠をまず塗らないフラグを立てます。
塗らないフラグと罫線を隔てていないセルは塗らなくて良いので、順次伝搬させています。
左上から右下へ、次は右下から左上へ、
このようにすることで、渦巻き型のような図形でも、ある程度効率的に処理されるようにしています。
Sub main()
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Cells.Interior.Color = xlNone
Dim maxRow As Long, maxCol As Long
With ws.UsedRange
If .CountLarge >= 10 ^ 8 Then MsgBox "ムリ!待てない!": Exit Sub
maxRow = .Item(.Count).Row
maxCol = .Item(.Count).Column
End With
Dim inDic As New Dictionary
Dim outDic As New Dictionary
Dim ary() As Byte, rng As Range
For Each rng In ws.UsedRange
If Not inDic.Exists(rng.Row & " " & rng.Column) And _
Not outDic.Exists(rng.Row & " " & rng.Column) Then
ReDim ary(1 To maxRow, 1 To maxCol)
If fillClosed(ary, rng) Then
Call addDictionary(inDic, ary)
Else
Call addDictionary(outDic, ary)
End If
End If
Next
Dim i As Long, j As Long
Dim uRng As Range, v
For Each v In inDic
i = Split(v)(0)
j = Split(v)(1)
If uRng Is Nothing Then
Set uRng = ws.Cells(i, j)
Else
Set uRng = Union(uRng, ws.Cells(i, j))
End If
Next
If Not uRng Is Nothing Then uRng.Interior.Color = vbYellow
End Sub
Sub addDictionary(dic As Dictionary, ary() As Byte)
Dim i As Long, j As Long
For i = LBound(ary, 1) To UBound(ary, 1)
For j = LBound(ary, 2) To UBound(ary, 2)
If ary(i, j) = 1 Then
dic(i & " " & j) = ""
End If
Next
Next
End Sub
Function fillClosed(ary() As Byte, rng As Range) As Boolean
ary(rng.Row, rng.Column) = 1
fillClosed = False
If rng.Borders(xlEdgeTop).LineStyle = xlNone Then
If rng.Row = LBound(ary, 1) Then Exit Function
If nextRange(ary, OffSet(rng, -1)) Then Exit Function
End If
If rng.Borders(xlEdgeBottom).LineStyle = xlNone Then
If rng.Row = UBound(ary, 1) Then Exit Function
If nextRange(ary, OffSet(rng, 1)) Then Exit Function
End If
If rng.Borders(xlEdgeLeft).LineStyle = xlNone Then
If rng.Column = LBound(ary, 2) Then Exit Function
If nextRange(ary, OffSet(rng, , -1)) Then Exit Function
End If
If rng.Borders(xlEdgeRight).LineStyle = xlNone Then
If rng.Column = UBound(ary, 2) Then Exit Function
If nextRange(ary, OffSet(rng, , 1)) Then Exit Function
End If
fillClosed = True
End Function
Function nextRange(ary() As Byte, rng As Range) As Boolean
If ary(rng.Row, rng.Column) = 0 Then
nextRange = Not fillClosed(ary, rng)
End If
End Function
Function OffSet(aRng As Range, Optional aRow As Long = 0, Optional aCol As Long = 0) As Range
Set OffSet = aRng.Worksheet.Cells(aRng.Row + aRow, aRng.Column + aCol)
End Function
範囲を少し広げると、スタック領域が不足してしまいます。

再帰処理は、回数がある程度限定されている場合でしか使えません。
同じテーマ「VBA100本ノック」の記事
61本目:「ふりがな」の取得と設定
62本目:独自のZLOOKUP関数を作成
63本目:複数シートの連結
64本目:リンクされた図(カメラ機能)
65本目:固定長テキスト出力
66本目:全サブフォルダからファイルを探す
67本目:ComboBoxとListBox
68本目:全テキストボックスの転記
魔球編:組み合わせ問題
魔球編:閉領域の塗り潰し
迷宮編:巡回セル問題
新着記事NEW ・・・新着記事一覧を見る
VBA100本ノック 68本目:全テキストボックスの転記|VBA練習問題(1月16日)
VBA100本ノック 67本目:ComboBoxとListBox|VBA練習問題(1月15日)
VBA100本ノック 66本目:全サブフォルダからファイルを探す|VBA練習問題(1月13日)
VBA100本ノック 65本目:固定長テキスト出力|VBA練習問題(1月12日)
VBA100本ノック 64本目:リンクされた図(カメラ機能)|VBA練習問題(1月11日)
VBA100本ノック 63本目:複数シートの連結|VBA練習問題(1月9日)
VBA100本ノック 62本目:独自のZLOOKUP関数を作成|VBA練習問題(1月8日)
VBA100本ノック 61本目:「ふりがな」の取得と設定|VBA練習問題(1月6日)
VBA100本ノック 60本目:「株式会社」の表記ゆれ置換|VBA練習問題(1月5日)
VBA100本ノック 59本目:12ヶ月分のシートを四半期で分割|VBA練習問題(1月4日)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.繰り返し処理(Do Loop)|VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 魔球編:閉領域の塗り潰し
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。