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

VBAを100本の練習問題で鍛えます
最終更新日:2020-12-21

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


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


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


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック 魔球編

マクロ VBA 100本ノック 魔球編


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

マクロ VBA 100本ノック 魔球編


やり方その1の動き

マクロ VBA 100本ノック 魔球編


やり方その2の動き

マクロ VBA 100本ノック 魔球編


VBA作成タイム

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


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


頂いた回答

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

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

解答

端から塗らない場所を順次拡大していく方法と、
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

範囲を少し広げると、スタック領域が不足してしまいます。

マクロ VBA サンプル画像

これはどうしようもないですね。
再帰処理は、回数がある程度限定されている場合でしか使えません。




同じテーマ「VBA100本ノック」の記事

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


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

文字列のプロパティ名でオブジェクトを操作する方法|VBA技術解説(2022-12-14)
数字(1~50)を丸付き数字に変換するVBA|VBA技術解説(2022-11-15)
TEXTAFTER関数(テキストの指定文字列より後ろの部分を返す)|エクセル入門(2022-11-14)
TEXTBEFORE関数(テキストの指定文字列より前の部分を返す)|エクセル入門(2022-11-14)
TEXTSPLIT関数(列と行の区切り記号で文字列を分割)|エクセル入門(2022-11-12)
LAMBDA以降の新関数はVBAで使えるか|VBA技術解説(2022-11-11)
WRAPCOLS関数(1次元配列を指定数の列で折り返す)|エクセル入門(2022-11-08)
WRAPROWS関数(1次元配列を指定数の行で折り返す)|エクセル入門(2022-11-08)
EXPAND関数(配列を指定された行と列に拡張する)|エクセル入門(2022-11-07)
TAKE関数(配列の先頭/末尾から指定行/列数を取得)|エクセル入門(2022-11-06)


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

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.マクロって何?VBAって何?|VBA入門
10.繰り返し処理(Do Loop)|VBA入門




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


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



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