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ソースが公開されているもの

解答

端から塗らない場所を順次拡大していく方法と、
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本ノック」の記事

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入門




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


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



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