[Excel VBA]グループの折り畳み

発端

発端はばっちりさんのツィートからです。

Excelの行とか列のグループって、VBAだと難しいね。
表示非表示の切替えってリボンにはあるのにVBAで記録できないんだもん。調べても対応するのがShowLevelsしかないし。
アクティブセルの行がグループ化されてる時に表示非表示を切り替えたいのに。
— バッチリ@Excel大好き仕事転がすマン (@batch_success) 2019年4月23日

動作確認してみると、この「ShowLevels」ってメソッド、アウトラインで表示されている数字ボタンを押したときと同じ動作でした。

なので、アクティブセルの行がグループ化されてる時に、というニーズには合わないのです。

動画

f:id:wd4096:20190424052116g:plain

コード/解説

「psToggle」を呼び出すと、アクティブセルについてグループを畳んだり開いたりします。

アウトライン表示の折り畳みは単純に行・列を非表示にしているだけなので、対象範囲を抽出後、隠せばOKなのです。

rangeオブジェクトを確認すると、OutlineLevelというプロパティが見つかりましたので、これを利用してコードを組みました。

なお、アウトライン表示にはオプションがあって、集計行の位置を、詳細行の上下いずれにするかを選べるのです。

どちらを選んだかはOutlineオプションの「SummaryRow」プロパティで判定できるので、これで分岐して表示します。

なお、今回、「グループ化されている行」をすべてのレベル一斉に畳むようにしましたが、Excelのリボンについているボタンと同じ動作にする場合は、上下への検索条件を「1以上」から「ActivecellのOutlineLevelと同じ」に変更する必要があります。

大きな修正にはなりませんので、あとはお好みでどうぞ、なのです。

Option Explicit

Sub psToggle()
    '選択セルの行がグループ化されている場合、閉じる
    If Rows(ActiveCell.Row).OutlineLevel > 1 Then
        '上へ向かって探索、下へ向かって探索、隠す
        Range(Rows(search2Up(ActiveCell)), Rows(search2Down(ActiveCell))).Hidden = True
    Else
        Select Case ActiveSheet.Outline.SummaryRow
            Case 0
                '集計行は詳細行の上
                '1行下が隠れていて、かつ、Outlineレベルが2以上であるとき、
                '折りたたまれていると判定して、開く
                If (Rows(ActiveCell.Row + 1).OutlineLevel < 1048576) And (Rows(ActiveCell.Row + 1).Hidden) Then
                    '下へ向かって探索、表示する
                    Range(Rows(ActiveCell.Row), Rows(search2Down(ActiveCell))).Hidden = False
                End If
            Case 1
                '集計行は詳細行の下
                '1行上が隠れていて、かつ、Outlineレベルが2以上であるとき、
                '折りたたまれていると判定して、開く
                If (Rows(ActiveCell.Row - 1).OutlineLevel > 1) And (Rows(ActiveCell.Row - 1).Hidden) Then
                    '上へ向かって探索、表示する
                    Range(Rows(search2Up(ActiveCell)), Rows(ActiveCell.Row)).Hidden = False
                End If
        End Select
    End If
End Sub

Function search2Up(objRange As Range) As Long
Dim lngFirst As Long

    '上へ向かって探索
    lngFirst = objRange.Row
    If lngFirst - 1 > 1 Then
        Do While (lngFirst - 1 > 1) And (Rows(lngFirst - 1).OutlineLevel > 1)
            lngFirst = lngFirst - 1
        Loop
    End If
    
    search2Up = lngFirst
End Function

Function search2Down(objRange As Range) As Long
Dim lngLast As Long

    '下へ向かって探索
    lngLast = objRange.Row
    If lngLast + 1 < 1048576 Then
        Do While (lngLast + 1 < 1048576) And (Rows(lngLast + 1).OutlineLevel > 1)
            lngLast = lngLast + 1
        Loop
    End If
    
    search2Down = lngLast
End Function