アウトライナーもどきをExcelマクロで自作していた、1999年。

投稿日 2018 年 9 月 20 日
著者大橋悦夫
カテゴリー Journal

Excel VBA

ファイルの整理をしていたら、アウトライナーもどきのExcelシート（マクロ）が出てきました。

「－」のセルを選択して「展開折り畳み」をクリックすると折りたたみ。
「＋」のセルを選択して「展開折り畳み」をクリックすると展開。

選択したセルの配下にある行の非表示・表示を切り替えるだけのマクロですが（動作スピードも極めて遅いですが）、当時はこれで十分でした。

これを作ったのは1999年（会社員3年目）で、当然のごとくWorkflowやDynalistなどは存在しなかったので自作したのですが、Wordのアウトラインモードを使えば済むところです。

要するに当時はマクロ作りに夢中だったわけです。

見ていただくとわかるとおり、目標設定のために作りました。

ソース

以下がソースです。シート上にボタンを作り、「FoldMain」をマクロ登録すると動きます。キーボードショートカットを割り当てても良いでしょう（手順は割愛します）。

　
Option Explicit
Public Const mlngMaxLevel As Long = 6

'「展開折り畳み」ボタンに登録
Sub FoldMain()
    Dim lngRowDef As Long
    
    lngRowDef = Selection.Row
    With Application
        .ScreenUpdating = False
        Call SetFoldRows(lngRowDef)
        .ScreenUpdating = True
    End With
End Sub

Sub SetFoldRows(lngRowDef As Long)
    Dim lngLevelDef As Long
    Dim lngRow As Long
    Dim lngLevel As Long
    
    'Default Row,Level
    lngRow = lngRowDef
    lngLevelDef = Cells(lngRow, 1)
    lngLevel = lngLevelDef
    
    'Is Existence of Contents
    If lngLevel = 0 Then
        Exit Sub
    End If
    
    'Is Existence of Child(ren)
    If lngLevel >= Cells(lngRow + 1, 1) Then
        Exit Sub
    End If
    
    'Add Mark "+/-"
    AddMark lngRow, lngLevel
    
    'Fold/Expand
    Call FoldRows(lngRow, lngLevel, Left(Selection, 1))
    
    'Set Cursor on the Mark
    Cells(lngRowDef, lngLevelDef + 1).Select
End Sub

Sub AddMark(plngRow As Long, plngLevel As Long)
    If Cells(plngRow + 1, 1).RowHeight = 0 Then
        'Add "-" for Expanded
        With Cells(plngRow, plngLevel + 1)
            Select Case Left(.Value, 1)
                Case "－"
                Case "＋"
                    .Value = "'－ " & Right(.Value, Len(.Value) - 2)
                Case Else
                    .Value = "'－ " & Right(.Value, Len(.Value))
            End Select
        End With
    Else
        'Add "+" for Folded
        With Cells(plngRow, plngLevel + 1)
            Select Case Left(.Value, 1)
                Case "＋"
                Case "－"
                    .Value = "'＋ " & Right(.Value, Len(.Value) - 2)
                Case Else
                    .Value = "'＋ " & Right(.Value, Len(.Value))
            End Select
        End With
    End If
End Sub

Sub FoldRows(plngRowE As Long, plngLevelDef As Long, pstrMark As String)
    Dim lngRowHeightDef As Long
    Dim lngRowHeight As Long
    Dim lngRowS As Long
    Dim lngLevel As Long
    Dim isBreak As Boolean
        
    'Choose Fold(+) or Expand(-)
    Select Case pstrMark
        Case "＋"
            lngRowHeight = 0
        Case "－"
            lngRowHeight = Selection.RowHeight
        Case Else
            Call ErrorEnd("プログラム内部エラー／Sub FoldRows")
    End Select
    
    'Set Fold/Expand Range
    lngLevel = plngLevelDef + 1
    isBreak = False
    
    Do Until lngLevel <= plngLevelDef
        plngRowE = plngRowE + 1
        If isBreak = False Then
            lngRowS = plngRowE
            isBreak = True
        End If
        lngLevel = Cells(plngRowE, 1)
    Loop
    
    'Fold/Expand
    With Range(Cells(lngRowS, 1), Cells(plngRowE - 1, mlngMaxLevel))
        If lngRowHeight > 0 Then
            'Replace + to -
            .Replace What:="＋", Replacement:="－", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False
            .EntireRow.AutoFit
        Else
            .RowHeight = lngRowHeight
        End If
    End With
End Sub

Sub ErrorEnd(pstrMsg As String)
    If pstrMsg <> "" Then
        Call MsgBox(pstrMsg, , "エラー")
    End If
    Application.ScreenUpdating = True
    End
End Sub