Option Explicit
Private Tree As Worksheet, 作業sheet As Worksheet, 階層図 As Worksheet
Private Treeの行末 As Long, 表示行 As Long
Sub Tree図()
Dim 行1 As Long, 行2 As Long, 行末 As Long
Set Tree = Worksheets("Tree")
Set 作業sheet = Worksheets("作業sheet")
Set 階層図 = Worksheets("階層図")
作業sheet.UsedRange.Clear
階層図.UsedRange.Clear
Treeの行末 = Tree.Range("A1").End(xlDown).row
行2 = 1
For 行1 = 2 To Treeの行末
If Tree.Cells(行1, 1) = "Root" Then
作業sheet.Cells(行2, 1) = Tree.Cells(行1, 2)
行2 = 行2 + 1
End If
Next 行1
行末 = 行2 - 1
表示行 = 1
For 行2 = 1 To 行末
階層図.Cells(表示行, 1) = "" & 作業sheet.Cells(行2, 1).Text
表示行 = 表示行 + 1
ツリー図2 作業sheet.Cells(行2, 1).Text, 2
Next 行2
End Sub
Private Function ツリー図2(今のID As String, 階層)
' 親列(A列)から子列(B列)を列挙しソートする
Dim 行1 As Long, 行2 As Long, 行末 As Long, 列 As String, 罫線 As String
行2 = 1
For 行1 = 2 To Treeの行末
If Tree.Cells(行1, 1) = 今のID Then
作業sheet.Cells(行2, 階層) = Tree.Cells(行1, 2)
行2 = 行2 + 1
End If
Next 行1
行末 = 行2 - 1
'ASCII【ｱｽｷｰ】コード表 Chr(64) 数字の＠を指し、65は、A列 66は、B列を指す
列 = Chr(64 + 階層)
' 見やすくするため ID 番号順に並べ替え
If 行末 > 1 Then _
作業sheet.Range(列 & "1:" & 列 & 行末).Sort Key1:=作業sheet.Range(列 & "1"), _
Order1:=xlAscending, header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
'順に再帰コール
If 行末 > 0 Then
For 行2 = 1 To 行末
If 行2 = 行末 Then 罫線 = "└" Else 罫線 = "├"
階層図.Cells(表示行, 階層 - 1) = 罫線
階層図.Cells(表示行, 階層) = "" & 作業sheet.Cells(行2, 階層).Text
表示行 = 表示行 + 1
ツリー図2 作業sheet.Cells(行2, 階層).Text, 階層 + 1
Next 行2
End If
End Function
