文字けい線を使った階層図を作成する

Sub 文字罫線で階層図作成()

    Dim rngTa As Range
    Dim rMax As Long, r As Long, c As Long
    Dim flgOn As Boolean
    Dim aryCh As Variant
    
    aryCh = Array("┃", "┳━", "━━", "┣━", "┗━")
    
    Set rngTa = ActiveSheet.UsedRange
    rMax = rngTa.Rows.Count
    
    '各列の重複解消
    For c = rngTa.Columns.Count To 1 Step -1
        For r = rMax To 2 Step -1
            With rngTa(r, c)
                '上と同じ値
                If .Value <> 0 And .Value = .Offset(-1, 0) Then
                    '1列目
                    If c = 1 Then
                        .ClearContents
                    '2列目以降 前列と同じ値
                    ElseIf .Offset(0, -1) = .Offset(-1, -1) Then
                        .ClearContents
                    End If
                End If
            End With
        Next r
    Next c

    '文字罫 入力列を挿入。
    For c = rngTa.Columns.Count To 2 Step -1
        rngTa.Columns(c).Insert shift:=xlShiftToRight
    Next c
    
    '文字罫 入力
    For c = rngTa.Columns.Count To 2 Step -2
        For r = rMax To 1 Step -1
            With rngTa(r, c)
                If .Value > 0 Then '自値あり
                    If .Offset(0, -2) > 0 Then '親値あり
                        .Offset(0, -1) = IIf(flgOn = True, aryCh(1), aryCh(2))
                        flgOn = False
                    Else '親値なし
                        .Offset(0, -1) = IIf(flgOn = True, aryCh(3), aryCh(4))
                        flgOn = True
                    End If
                ElseIf flgOn = True Then '自値なし
                    .Offset(0, -1) = aryCh(0)
                End If
            End With
        Next r
    Next c
    
    '罫線列の幅調整
    For c = 2 To rngTa.Columns.Count Step 2
        rngTa.Columns(c).ColumnWidth = 2
    Next c
    
    Set rngTa = Nothing
End Sub