VBA100本ノック魔球編：閉領域の塗り潰し

最終更新日：2020-12-21

VBA100本ノック魔球編：閉領域の塗り潰し

四方を罫線で囲まれている範囲内のセルを塗りつぶす問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

出題

#VBA100本ノック魔球編2
シート内のセルが四辺の罫線（線種は問わず）で完全に塞がれている閉じた範囲内にある場合、罫線で閉じられたセル範囲を黄色(好きな色)で塗りつぶしてください。
シートの端も罫線があるか無いかで判定してください。
※閉じられた範囲とは画像の黄色部分になります。

いつもは問題出した時点ではVBA書いてないのですけど、今回はイメージ通りにVBA作れるのかちょっと不安があったので、先にVBA書いてみました。
まあ、まだかろうじてボケてはいないようです口を開けて冷や汗をかいた笑顔
妻からは完全にボケ爺さん扱いされていますけど号泣

やり方その1の動き

やり方その2の動き

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

VBAソースが公開されているもの

@excelspeedup ・・・ m-haketa/colorInnerCell.vb

@blacklist_ryu ・・・魔球2

@kyrtnyy ・・・ノック魔球2：きょろ

解答

端から塗らない場所を順次拡大していく方法と、
4方向再帰していく方法の2通り作成しました。
4方向再帰は範囲が広いと、スタック領域が不足してしまいます。
結局、囲碁で相手の石を囲んで取るアルゴリズムをほとんどそのまま使ったかんじになりました。

解答VBAコード

囲碁で相手の石を囲んで取るアルゴリズム

・囲碁で相手の石をとる・お題のツイート・Excel囲碁で実装したVBA ・突然思いついた処理方法・両者のパフォーマンス比較・まとめ

ここでのアルゴリズムがほぼそのまま使えます。

端から塗らない場所を順次拡大・・・やり方その1の動き


  
    
      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広げた配列を用意し、
その外枠をまず塗らないフラグを立てます。
塗らないフラグと罫線を隔てていないセルは塗らなくて良いので、順次伝搬させています。
左上から右下へ、次は右下から左上へ、
このようにすることで、渦巻き型のような図形でも、ある程度効率的に処理されるようにしています。

※変数の入れ替えには以下の考え方を使っています。

数値変数の値を別の変数を使わずに入れ替える

・問題を出したツイート・お寄せいただいた回答・用意した解答

4方向再帰・・・やり方その2の動き


  
    
      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本ノック」の記事

95本目：図形のテキストを検索するフォーム作成
 96本目：Accessデータを取得（マスタ結合&抽出）
97本目：Accessデータを取得（グループ集計）
98本目：席替えルールが守られているか確認
 99本目：自動席替え（行列と前後左右が全て違うように）
100本目：WEBから100本ノックのリストを取得
 魔球編：組み合わせ問題
魔球編：閉領域の塗り潰し
迷宮編：巡回セル問題
 魔球編：2桁の最小公倍数
 参加者様ご紹介

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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.繰り返し処理（For Next)｜VBA入門
5.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
6.Excelショートカットキー一覧｜Excelリファレンス
7.並べ替え（Sort）｜VBA入門
8.マクロって何？VBAって何？｜VBA入門
9.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
10.エクセルVBAでのシート指定方法｜VBA技術解説

ホーム
マクロVBA入門編
VBA100本ノック
魔球編：閉領域の塗り潰し

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

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

VBA練習問題
VBA100本ノック魔球編：閉領域の塗り潰し