シーゴの Excel 研究室

タイトル変更しました （旧称：今日を乗り切るExcel研究所）

トップ > VBA > 【VBA】階層見出しをデータ構造に変換したい【100本ノック】

【VBA】階層見出しをデータ構造に変換したい【100本ノック】

VBA

エクセルの神髄様の Twitter 企画 「VBA100本ノック」の 42 本目になります。

お題：VBA100本ノック 42本目：データベース形式に変換

問題ページ

方針

アウトライン、ツリー、カスケード、階層見出しなどいくつか呼び方があるようですが、このような階層的に表現された一覧表をよく目にしますね。

今回はこの階層表現を通常のフラットな表形式に変換するという課題です。

これも表組み換えの一種と言え、VBA が役に立つ場面でしょう。

VBAでセルを辿るロジックを組むのも楽しいのですが、問題ページの解説にある解答例では SpecialCells メソッドと数式を使ったスマートな方法が紹介されています。

本ブログでも Excel 機能を使ってできるだけ一括変換する方法がないか考えてみます。

解答

Option Explicit

Sub VBA100_042()
    Application.ScreenUpdating = False
    
    Dim tree As Range
    Set tree = ActiveWorkbook.Worksheets("階層").Range("A1").CurrentRegion
        
    Dim list As Range
    Set list = ActiveWorkbook.Worksheets("階層DB").Range(tree.Address)
    list.Clear
    
    ' 一つ上のセルを参照する数式を設定
    Intersect(list, list.Offset(1)).Formula = "=A1"     ' list.Range("A1").Address(False,False)
    list.Columns(list.Columns.Count).Clear              ' 右端の列は除外
        
    ' 階層見出しを「空白を無視する」で貼り付け
    tree.Copy
    list.PasteSpecial SkipBlanks:=True
    list.Value = list.Value                             ' 値に変換
    
    ' 右端の列が空白となる行を削除
    list.AutoFilter list.Columns.Count, ""
    list.Offset(1).Delete xlShiftUp
    list.AutoFilter
    
    list.Worksheet.Activate
    list.Range("A1").Select

    Application.ScreenUpdating = True
End Sub

　

　

考察

一括変換するポイントは、階層見出しの空白セルをどう埋めるのかと、余分な行を削除する方法です。

空白セルを項目で埋めるため、数式と「空白を無視する」貼り付けを使いました。

余分な行はオートフィルターで絞り込んだ後に一括で削除します。

1. 一つ上のセルを参照

まず変換先のセル範囲を、一つ上のセルを参照する数式で敷き詰めておきます。

一番右の「詳細」（D列）を、数式設定の対象から外していますが、これはあとで不要な行を削除するための都合による伏線になります。

この段階では全ての数式の結果が 0 になっています。

f:id:shego:20210920183510p:plain

ところで複数セルからなるの Range に対して１個のアドレスを設定するのは変に思うかもしれません。

このとき A1 形式で表現された相対アドレスは、最初のセル（左上）からみたセルの位置関係を表します。

全てのセルが同一の数式になるということは、各セルからみたその相対的な位置関係が複製されるということになります。

    ' A1 形式で一つ上のセルを相対参照
    Range("A2:C10").Formula = "=A1"

    ' RC形式で一つ上のセルを相対参照
    Range("A2:C10").FormulaR1C1 = "=R[-1]C[0]"

2. 空白を無視して貼り付け

次に数式を敷き詰めたセル範囲に、階層見出しを「空白を無視する」で貼り付けます。

「空白を無視する」形式では、ステンシルのようにして値のあるセルだけが貼り付けられて、空白セルの位置の値が温存されます。

つまり階層項目のあるセルでは貼り付け先の数式が上書されますが、空白セルの位置の数式はそのまま残ります。

結果として、空白セルだった位置が項目と同じ値で埋められた状態となります。

f:id:shego:20210920173012p:plain

「形式を選択して貼り付け」に「空白を無視する」という形式があるのは知っていましたが、今まで使う機会もなく、今回初めて役にたちました。

f:id:shego:20210920172406p:plain

3. オートフィルターで絞り込み削除

最後に不要な行を削除しますが、先の結果を眺めると、右端の「詳細」列が空白になっている行を削除すればいいことが分かります。

セルの値によって行を削除するにはフィルターが使えます。

AutoFilter や AdverncedFilter で絞り込みをしたセル範囲に対する操作は、可視状態の Range が対象となります。

少し乱暴に見えますが、空白で絞り込みをした行を Delete してしまえば OK です。

f:id:shego:20210920173445p:plain

通常は絞り込み結果が０件の場合を考慮する必要があることが多いのですが、今回はなくても大丈夫そうです。

　

　

おまけ：階層見出しを作成する

逆向きの処理、すなわちフラットな階層データをアウトライン化できないか挑戦してみました。

Option Explicit


Sub 階層見出し化()
    Application.ScreenUpdating = False

    Worksheets("階層DB").Copy after:=Worksheets("階層DB")
    
    Dim rng As Range
    Set rng = Range("A1").CurrentRegion
    Set rng = Intersect(rng, rng.Offset(1))
    If rng Is Nothing Then Beep: Exit Sub
    
    rng.Value = Evaluate("IF(" & rng.Address & "=" & rng.Offset(-1).Address & ",""""," & rng.Address & ")")
    
    Dim itms() As Variant
    itms = rng.Value
        
    Dim tree() As Variant
    ReDim tree(1 To WorksheetFunction.CountA(rng), 1 To rng.Columns.Count)
    
    Dim n As Long
    Dim x As Long
    Dim y As Long
    n = 1
    For y = 1 To UBound(itms, 1)
        For x = 1 To UBound(itms, 2)
            If Not IsEmpty(itms(y, x)) Then
                tree(n, x) = itms(y, x)
                n = n + 1
            End If
        Next
    Next
    
    rng.Resize(UBound(tree, 1)).Value = tree

    Application.ScreenUpdating = true
End Sub

関連記事

www.shegolab.jp

www.shegolab.jp