【VBA】系統図作成マクロを作ってみた

お久しぶりです。
安定期に入り、つわりも落ち着き、プログラミングの勉強を再開しました。
職場復帰した時に役に立つもの作れないかな～と思い、
職場でよく使っていた系統図をもっと簡単に作れればいいなーと、ご無沙汰だったエクセルVBAをいじいじ。
系統図は新QC７つ道具の一つで、問題を解決すべき最適な手段や方策を系統的に追求する方法です。
本来の用途とはちょっとずれますが、問題や課題を具体的な要素まで抜け漏れなく分解するのにも役に立っていました。

作ったマクロでできるのはこんな図。

系統図例

子を追加したいとき、親枠を選択した状態で「追加マクロ」を実行すると、枠とコネクタ線が追加されます。
削除したい枠を選択した状態で「削除マクロ」を実行すると、枠と不要になったコネクタ線が削除されます。他の枠は、それに伴いスライドされます。
「次数出力マクロ」は、ただ設定した次数を出力するだけのおまけです。
あ、でも系統図の次数はI1セルに入力しておかないと、削除マクロがバグります。
なんでかというと、どこからどこまで探索すればいいのかをI1セルに入力されている次数で判断しているからです。
もっとうまくできる気がするんですけど、体力がないのでやる気がでたらやります。申し訳ないです。

今回エクセルファイルをアップできればよかったのですが、
できないみたいなので、申し訳ないですが、
使う際は下記のようにフォーマットを整える必要があります。

マクロを使うための下準備

【必須準備】
①目的、目標を入力する枠を作成する（図中①）。セルを二行結合して太枠で囲む。
②次数（系統図のうち目的・目標の列を除いた列の総数）を入力するセルを"I1"にする（図中②）

【任意準備】
追加や削除など、マクロを実行する際に使うボタンを作成しておく。
ボタン以外に、ショートカットキーを使ってもなんでもいいです。

以下VBAコード３つ。

「追加マクロ」

Sub 追加()
    Dim firstCell, newCell, lineCell As Range
    Dim endCol As Integer
    Dim i, j, a As Integer
    Dim firstrow, firstcol As String
    
    Set firstCell = Selection '選択セル
    firstrow = firstCell.Row '削除するセルの行番号
    firstcol = firstCell.Column '削除するセルの列番号
    
    '親要素を選択していない場合マクロ終了
    If firstCell.Borders(xlEdgeTop).LineStyle <> 1 Then '上枠判定だからいまいちだけど無いよりまし
        MsgBox "追加する要素の親を選択してからクリックしてね"
        Exit Sub
    End If
    
    '選択したセルの右３つめのセルにすでに枠が作成されていたら、
    If firstCell.Offset(0, 3).Borders(xlEdgeTop).LineStyle = xlContinuous Then
    '選択セルから分岐するセルの内、最も下に位置する枠の行数を取得し、その行の下に３つ行を追加して枠を作る。
        
        i = 1
        j = 1
                    
        Do Until Cells(firstrow + i, firstcol + j).Borders(xlEdgeRight).LineStyle = xlLineStyleNone And _
        Cells(firstrow + i, firstcol + j + 3).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
            If Cells(firstrow + i, firstcol + j).Borders(xlEdgeRight).LineStyle = xlContinuous Then
                i = i + 3
            ElseIf Cells(firstrow + i, firstcol + j + 3).Borders(xlEdgeTop).LineStyle = xlContinuous Then
                j = j + 3
            End If
        Loop
        
        Rows(firstrow + i + 1 & ":" & firstrow + i + 3).Insert 'newCell定義する前に挿入しないとおかしなことになった
        
        Set newCell = firstCell.Offset(i + 1, 3).Resize(2, 1)
        
    'firstCellの右三つ目のセルに枠がない場合、そのまま横に作成する。
    Else
        Set newCell = firstCell.Offset(0, 3).Resize(2, 1)
    
    End If
        
        newCell.Merge
        newCell.BorderAround Weight:=xlMedium
    
    '以下接続線作成部分
    'newCellとfirstCellが同じ行の場合は横に一本引く
    If firstCell.Row = newCell.Row Then
        Set lineCell = newCell.Offset(0, -2).Resize(1, 2)
        lineCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
        
    'そうでない場合はfirstCellからnewCell行までの縦線と、横線を引く
    Else
        Set lineCell = Range(Cells(firstCell.Row + 1, firstCell.Column + 2), Cells(newCell.Row, newCell.Column - 1))
        lineCell.Borders(xlEdgeLeft).LineStyle = xlContinuous
        lineCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
    
    End If

End Sub

「削除マクロ」

Sub 削除()

Dim DelCell As Range
Dim i, j, n, a, b As Long
Dim ad, delrow, delcol, botrow As String

Set DelCell = Selection '選択セル=削除するセル
delrow = DelCell.Row '削除するセルの行番号
delcol = DelCell.Column '削除するセルの列番号
    
    If DelCell.Borders(xlEdgeTop).LineStyle <> 1 Then '上枠判定だからいまいちだけど無いよりまし
        MsgBox "削除したい要素を選択してからクリックしてね"
        Exit Sub
    End If
    
    '選択したセルの右３つめのセルにすでに枠が作成されていたら(=選択セルが末端でなかったら)
    If DelCell.Offset(0, 3).Borders(xlEdgeTop).LineStyle = xlContinuous Then
        MsgBox "末端要素以外は消せません"
        Exit Sub
    End If

    '同じ行の左に親枠があり、同列下にも枠がある場合、そこから３行と右側を削除して上にシフト
    'そして繋がっていた一番下のセルがあった場所を３行削除
    
    
    a = 5 + 3 * (Range("I1").Value - 1) ' 系統図の右端列数
    b = DelCell.Offset(0, -1).Column
    
    
    If Cells(delrow, delcol - 3).Borders(xlEdgeTop).LineStyle = xlContinuous Then
        If Cells(delrow + 1, delcol - 1).Borders(xlEdgeLeft).LineStyle = xlContinuous Then
        
            i = 0
            n = 1


            Do
                i = i + 3
                Cells(delrow + i, delcol - 1).Resize(2, a - b + 1).Select 'デバッグ用
                Cells(delrow + i - 3, delcol - 1).Select 'デバッグ用
                Cells(delrow + i, delcol - 1).Resize(2, a - b + 1).Cut Cells(delrow + i - 3, delcol - 1) '上にカット&ペースト
                
            Loop Until Cells(delrow + i + 1, delcol - 1).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
            
            botrow = delrow + i - 1 '削除する行上端（ここから3行分、系統図列分削除）
            '罫線を消す
            Cells(delrow, delcol - 1).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
            '左端から三行削除
            Range(Cells(botrow, 1), Cells(botrow + 2, a)).Delete (xlShiftUp)
        
        Else
            Cells(delrow, delcol - 1).Resize(2, 3).Borders.LineStyle = xlLineStyleNone '左に枠あるけど下に付随する枠ないときはシンプルに枠消すだけ
            Cells(delrow, delcol - 2).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
        End If
    ElseIf Cells(delrow + 1, delcol - 1).Borders(xlEdgeLeft).LineStyle = xlContinuous Then '中間にある枠の場合
        '三行削除
        Range(Cells(delrow, 1), Cells(delrow + 2, a)).Delete (xlShiftUp)
    Else '最下枠の場合
        i = 0
        Do
            i = i - 1
            DelCell.Offset(i, -1).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
        Loop Until DelCell.Offset(i, -1).Borders(xlEdgeTop).LineStyle = xlContinuous
        delrow = DelCell.Row '削除する行上端（ここから3行分、系統図列分削除）
        Range(Cells(delrow, 1), Cells(delrow + 2, a)).Delete (xlShiftUp)
    End If
            
End Sub

「次数出力マクロ」

Sub 次数出力()

Dim num, a, i As Long
 

num = Range("I1").Value

    a = 1
    Do While InStr(Cells(3, 3 * a + 2).Value, "次") > 0
        Cells(3, 3 * a + 2).Clear
        a = a + 1
    Loop


    For i = 1 To num
        Cells(3, 3 * i + 2).Value = i & "次"
    Next i

End Sub

コードは以上です。
久しぶりのVBAは疲れました～。
思い出しながらなので、やたらコメントが多いですね。
改善の余地はありそうですが、気が向いたらじっくり考えます。
とりあえず、だいぶ楽になったので良いよね！

もっとこうしてほしいとか、何かあればコメントください。

以上です。