VBA WBSのように大中小カテゴリで階層ごとに結合されたセルをマクロで扱う方法

※WBSとは、Work Breakdown Structureのこと。プロジェクト管理なんかで使われる、仕事を段階的に細分化した表だ。まぁWBSのようにと言っておきながら、適当なサンプルが見つからなかったので全然WBSじゃないけど。Wikipediaから鳥類の分類表を拝借してきた。

業務ではこういう結合された表がよく出てくる。
f:id:t-hom:20161103062829p:plain

人間が見やすいように工夫されているのだが、フィルターをかけたり検索したりするのには使いづらい。
この記事ではこれを便宜上、階層形式と呼ぶことにする。

逆に以下のように1行1レコードのデータであれば、フィルターもかけられるし、特定の項目で並び替えもできる。
f:id:t-hom:20161103063231p:plain
こちらは、レコード形式と呼ぼう。

今回は、階層形式とレコード形式を相互変換するマクロを紹介する。

階層形式からレコード形式へ

これは別シートを使えばすこぶる簡単にできる。
まずレコード形式という名前で新規シートを挿入しておく。

それから標準モジュールに次のコードを書く。

Sub レコード形式に変換する()
    Dim r As Range
    For Each r In Selection
        Sheets("レコード形式").Range(r.Address).Value = r.MergeArea(1).Value
    Next
End Sub

あとは、こんなふうに階層形式のデータを全選択し、上記のマクロを実行するだけ。
f:id:t-hom:20161103064240p:plain

するとレコード形式シートにちゃんと1データ1レコードで転記されている。

なぜこんなに短いコードで書けるのか。
では、コードの詳細を説明しよう。

まず、結合セルの特性について。

結合セルを含む範囲をFor Each文でまわしたとき、結合セルに含まれる個別のセルに対して処理を行うことができる。
つまりr.Addressは選択範囲に含まれるセルのアドレスを1つずつ文字列で取り出していることになる。

これを選択範囲とは別のシート「レコード形式」のアドレスとして利用すると、別シートのまったく同じアドレスに対して書き込み処理ができる。

次に書き込むデータであるが、個別のセルに対してMergeAreaプロパティを参照すると、そのセルを含む結合範囲のRangeオブジェクトが取得できる。

たとえば「スズメ小綱」の結合範囲はD16:D24である。
f:id:t-hom:20161103065142p:plain
Range("D16").MergeAreaとすればRange("D16:D24")が取得される。
Range("D20").MergeAreaと書いても同じようにRange("D16:D24")が取得される。

データは必ず結合範囲の1番目のセルに入っているので、
Range("D16").MergeArea(1).Valueとすれば"スズメ小綱"が取得される。
Range("D20").MergeArea(1).Valueと書いても同じように"スズメ小綱"が取得される。

これで、もう一度先ほどのコードを確認していただければ、仕組みがわかると思う。

さて、別のシートなんて使いたくないっていうケースは、以下のマクロを使用する。

Sub レコード形式に変換する()
    Const アドレス = 1, データ = 2
    Dim 範囲 As Range: Set 範囲 = Selection
    Dim 配列() As Variant: ReDim 配列(1 To 範囲.Count, アドレス To データ)

    Dim i As Long
    For i = 1 To 範囲.Count
        配列(i, アドレス) = 範囲(i).Address
        配列(i, データ) = 範囲(i).MergeArea(1).Value
    Next
    
    範囲.UnMerge
    
    Dim j As Long
    For j = 1 To 範囲.Count
        Range(配列(j, アドレス)).Value = 配列(j, データ)
    Next
End Sub

ユーザーの領分※を極力侵さないという観点からは、こちらのほうが優れている。
ただコードはずいぶん長くなってしまうので自分で使うなら最初に紹介したマクロのほうが楽だ。

「ユーザーの領分」については以下の記事を参照。
thom.hateblo.jp

2018/12/12 追記

Twitterでお世話になってる羽毛田さんが、よりスマートなコードを紹介されたのでリンクしておく。
www.excelspeedup.com

レコード形式から階層形式へ

レコード形式から階層形式への変換は少々面倒くさい。
プログラムのバグはループの終了条件に集中しやすいが、これは割と終了条件が混乱しやすいマクロになるからだ。

コードはこちら。

Sub 階層形式に変換する()
    Dim 範囲 As Range: Set 範囲 = Selection
    
    Dim 開始列 As Long: 開始列 = 範囲(1).Column
    Dim 終了列 As Long: 終了列 = 範囲(範囲.Count).Column
    Dim 最終行 As Long: 最終行 = 範囲(範囲.Count).Row
    
    Dim マージ開始行 As Long, マージ終了行 As Long, 列 As Long
    
    For 列 = 開始列 To 終了列
        マージ開始行 = 範囲(1).Row
        マージ終了行 = マージ開始行
        Do Until マージ開始行 > 最終行
            Do While _
                Cells(マージ終了行 + 1, 列).Value = Cells(マージ開始行, 列).Value _
                And Cells(マージ終了行 + 1, 列).Value <> "-"
                    マージ終了行 = マージ終了行 + 1
            Loop
            
            If マージ開始行 < マージ終了行 Then
                Application.DisplayAlerts = False
                Range(Cells(マージ開始行, 列), Cells(マージ終了行, 列)).Merge
                Application.DisplayAlerts = True
            End If
            マージ開始行 = マージ終了行 + 1
            マージ終了行 = マージ開始行
        Loop
    Next
End Sub

やっていることは、マージ範囲を表すマージ開始行とマージ終了行を確定させてからマージしているだけ。
次の行の値が同じの間、マージ終了行を進め、異なる値が出てきたらそこで確定させる。
ループの最後にさきほどマージした範囲の次をマージ開始行に設定し、マージ終了行もマージ開始行と同じにセットしておく。
これの繰り返し。

結合の代わりに空白で表された階層構造を処理する

業務では、ときおりこういうデータも登場する。
f:id:t-hom:20161103081345p:plain
特にファイルサーバーのフォルダ階層ごとの容量レポートとかに多い気がする。
ここでは便宜的に空白形式と呼ぼう。

まぁ、作るのは簡単。
結合された階層形式を全選択し、単に結合解除すればできあがる。マクロを使うまでもない。

しかし結合された階層形式に戻したり、レコード形式に変換するのは割と骨が折れる。

直接レコード形式にするマクロは何度か書いたことがあるが、まぁここは先ほどのマクロをちょっといじって一旦階層形式をサクッと作ってしまおう。

こちらのコードも、選択範囲に対して実行される。

Sub 空白セルを結合する()
    Dim 範囲 As Range: Set 範囲 = Selection
    
    Dim 開始列 As Long: 開始列 = 範囲(1).Column
    Dim 終了列 As Long: 終了列 = 範囲(範囲.Count).Column
    Dim 最終行 As Long: 最終行 = 範囲(範囲.Count).Row
    
    Dim マージ開始行 As Long, マージ終了行 As Long, 列 As Long
    
    For 列 = 開始列 To 終了列
        マージ開始行 = 範囲(1).Row
        マージ終了行 = マージ開始行
        Do Until マージ開始行 > 最終行
            Do While Cells(マージ終了行 + 1, 列).Value = "" And マージ終了行 < 最終行
                マージ終了行 = マージ終了行 + 1
            Loop
            
            If マージ開始行 < マージ終了行 Then
                Range(Cells(マージ開始行, 列), Cells(マージ終了行, 列)).Merge
            End If
            マージ開始行 = マージ終了行 + 1
            マージ終了行 = マージ開始行
        Loop
    Next
End Sub