「今さら」なんてない

「自分にもできそう」を伝播させるブログ

Excel VBA 折畳・展開 & ズームイン・アウト(タスク管理ツール補助機能)

こちらの記事で紹介したExcelタスク管理ツールの補助機能の紹介です。
はじめての方はまずはこちらの記事をどうぞ。 yoshino-ya.hatenablog.com

併せてフィルタリングもインストールしておいて下さい。
 ※なくても折畳・展開はできますがズームが動作しません



それでは本題です。

目次

概要

折畳_展開

左端の+、ーからでも折畳・展開はできますが、面倒くさいのでダブルクリックでできるようにしました。

ズームイン

選択したタスクのみの表示に切り替えます。

ズームアウト

ズームインする前の(正確には最後のフィルタリング(F4)歴の)状態に戻します。

結合セルの解除

(おまけ)整理できてなくてこのモジュール内にたまたま入っていたのでついでに。まだ再描画(F5)にバグが残っていて、意図せぬ結合化が発生したときの為に使っています。

やること

Sheetモジュール”マスタ”にコードをコピペする

標準モジュールを挿入し、コードをコピペする

ショートカットの割当

ショートカット割当方法はこちらをどうぞ

yoshino-ya.hatenablog.com

ショートカットの割当例

キー1 キー2 キー3 動作
Alt {RIGHT} ズームイン
Alt {LEFT} ズームアウト
Ctrl m 結合セルの解除

コピペするコード

Sheetモジュール”マスタ”用

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    Call 折畳_展開
End Sub

標準モジュール用

Option Explicit
    Dim 選択セルの行数 As Long
    Dim 選択セルの最後の行  As Long

Sub 折畳_展開()
    '画面更新非表示
        Application.ScreenUpdating = False
    
    '現在セルが1行のものは処理しない
        If ActiveCell.MergeArea.Rows.Count = 1 Then: Exit Sub

    '条件分岐・処理
        If Cells(ActiveCell.Row + 1, ActiveCell.Column). _
            EntireRow.Hidden = True Then
            Call 折畳展開メイン(False)
        Else
            Call 折畳展開メイン(True)
        End If
    
    '画面更新有効化
        Application.ScreenUpdating = True

End Sub

Sub 折畳展開メイン(Tなら折畳_Fなら展開 As Boolean)
    With ActiveCell
        選択セルの最後の行 = .Row + .MergeArea.Rows.Count - 1
        Rows(.Row + 1 & ":" & 選択セルの最後の行).Hidden = Tなら折畳_Fなら展開
    End With
End Sub

Sub 結合セルの解除()
    Selection.UnMerge
End Sub


Sub ズームイン()
    Dim 表示開始行, 表示終了行, 最終行
    Dim 現在のセル行, 現在のセル列
    
    '画面更新非表示
        Application.ScreenUpdating = False
        
    '前置き
        現在のセル行 = ActiveCell.Row
        現在のセル列 = ActiveCell.Column
    
    'ズーム範囲の取得
        表示開始行 = Selection(1).Row
        表示終了行 = Selection(Selection.Count).Row
        最終行 = Rows.Count
        
    'ズーム範囲をレジストリに保存する
        SaveSetting "MyMacro", "マスタ", "表示開始行", 表示開始行
        SaveSetting "MyMacro", "マスタ", "表示終了行", 表示終了行

    'フィルタ解除ONの場合、ズームできないのでズーム前に解除する
        '// オートフィルタが解除されている場合
        If (ActiveSheet.AutoFilterMode = True) Then: _
            ActiveSheet.Range("D1").AutoFilter
    
    'ズーム処理
        Rows(1 & ":" & 表示開始行 - 1).Hidden = True
        Rows(表示終了行 + 1 & ":" & 最終行).Hidden = True
        'Call 展開する
        
    'タイトル行は常に表示する
        Rows(7).Hidden = False
        
    
    '画面更新有効化
        Application.ScreenUpdating = True
    
    '元いたセルを選択する
        Cells(現在のセル行, 現在のセル列).Activate
    
End Sub

Sub ズームアウト()
    Dim Rlast, Clast, 状態フィルタリスト, カテゴリフィルタリスト
    Dim 現在のセル行, 現在のセル列

    現在のセル行 = ActiveCell.Row
    現在のセル列 = ActiveCell.Column
    
    '画面更新非表示
        Application.ScreenUpdating = False
        
    'メイン
        Rows.Hidden = False
        
    'フィルタを前の状態に戻す
        '最終行・列を取得しておく(フィルタ範囲用)
            Rlast = GetSetting("MyMacro", "マスタ", "最終行")
            Clast = GetSetting("MyMacro", "マスタ", "最終列")
        
        '表示開始行・終了行を元に戻しておく
            SaveSetting "MyMacro", "マスタ", "表示開始行", タイトル行
            SaveSetting "MyMacro", "マスタ", "表示終了行", Rlast
        
        '選択状態の呼び出し
            状態フィルタリスト = Split(GetSetting("MyMacro", "Form", "状態フィルタ"), ",")
            カテゴリフィルタリスト = Split(GetSetting("MyMacro", "Form", "カテゴリフィルタ"), ",")
        
        '既にフィルタがかかっていれば解除しておく
            ActiveSheet.Range(Cells(7, "D"), Cells(Rlast, Clast)).AutoFilter
            
        'メイン
            ActiveSheet.Range(Cells(7, "D"), Cells(Rlast, Clast)).AutoFilter Field:=1, _
            Criteria1:=状態フィルタリスト, _
                Operator:=xlFilterValues
            ActiveSheet.Range(Cells(7, "D"), Cells(Rlast, Clast)).AutoFilter Field:=8, _
            Criteria1:=カテゴリフィルタリスト, _
                Operator:=xlFilterValues
        
        '後処理
            Cells(現在のセル行, 現在のセル列).Select
            ActiveSheet.Outline.ShowLevels RowLevels:=1
        
    
    '画面更新有効化
        Application.ScreenUpdating = True
End Sub

以上です。

人にコードを渡すという工程の大切さというか有意義な感じを痛感しています。毎度、新しいブックにコードだけコピペして動作確認をする度にエラーが出てしまいます、、、主に変数の宣言エラーなので応急的にそのプロシージャに宣言し直すことが多いのですが、恒久対策がすぐに打てるようになりたいですね、、、