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コード

囲碁で相手の石を囲んで取るアルゴリズム
ツイッターで出したVBAのお題です。Excel囲碁を作っていて、相手の石を囲んで取れるかどうかの判定、相手の石を取るにはどうしたら良いかというもの。囲碁で相手の石をとる ここで、8二に黒を打てば、このように囲まれている白が取られます。
ここでのアルゴリズムがほぼそのまま使えます。

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

※変数の入れ替えには以下の考え方を使っています。
数値変数の値を別の変数を使わずに入れ替える
ツイッターで出したエクセルVBAのお題です。数値が入っている3つの変数を、他の変数を使わずに値を入れ替えるという問題です。問題を出したツイート 【VBA問題】 変数a,b,cに整数値が入っています。これをa>b>cとなるように値を入れ替えてください。


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(2021-10-18)
還暦のVBA:VBAまでたどりつけるか… (2021-09-29)
VLOOKUPを使うことを基本としてシートを設計すべきか|エクセル雑感(2021-08-17)
コンピューターはブラックボックスで良い|エクセル雑感(2021-08-14)
小文字"abc"を大文字"ABC"に変換する方法|エクセル雑感(2021-08-13)
ADOでテキストデータを集計する|VBAサンプル集(2021-08-04)
VBA学習のお勧めコース|エクセル雑感(2021-08-01)
エクセル馬名ダービー|エクセル雑感(2021-07-21)
在庫を減らせ!毎日棚卸ししろ!|エクセル雑感(2021-07-05)
日付型と通貨型のValueとValue2について|エクセル雑感(2021-06-26)


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

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




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


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



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