Option Explicit
Private 親子 As Worksheet, 作業用 As Worksheet, 階層図 As Worksheet
Private 親子の行末 As Long, 表示行 As Long
Sub SwapColumnsAandB()
Dim ws As Worksheet
Dim lastRow As Long
Dim temp As Variant
Dim i As Long
' Set a reference to the "親子" worksheet
Set ws = ThisWorkbook.Worksheets("親子")
' Find the last row with data in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Loop through each row and swap the contents of columns A and B
For i = 1 To lastRow
temp = ws.Cells(i, 1).Value ' Store the value of column A in a temporary variable
ws.Cells(i, 1).Value = ws.Cells(i, 2).Value ' Copy the value from column B to column A
ws.Cells(i, 2).Value = temp ' Copy the value stored in the temporary variable to column B
Next i
End Sub
Sub ツリー階層()
SwapColumnsAandB
Dim 行1 As Long, 行2 As Long, 行末 As Long
Set 親子 = Worksheets("親子")
Set 作業用 = Worksheets("作業用")
Set 階層図 = Worksheets("階層図")
作業用.UsedRange.Clear
階層図.UsedRange.Clear
親子の行末 = 親子.Range("A1").End(xlDown).Row
行2 = 1
For 行1 = 2 To 親子の行末
If 親子.Cells(行1, 2) = "--" Then
作業用.Cells(行2, 1) = 親子.Cells(行1, 1)
行2 = 行2 + 1
End If
Next 行1
行末 = 行2 - 1
表示行 = 1
For 行2 = 1 To 行末
階層図.Cells(表示行, 1) = "■" & 作業用.Cells(行2, 1).Text
表示行 = 表示行 + 1
ツリー図2 作業用.Cells(行2, 1).Text, 2
Next 行2
SwapColumnsAandB
Sheets("階層図").Select
Range("A1").Select
End Sub
Private Function ツリー図2(今のID As String, 階層)
' 紹介者列から大元ID に紹介されたID(A列)を列挙しソートする
Dim 行1 As Long, 行2 As Long, 行末 As Long, 列 As String, 罫線 As String
' 紹介者列から大元ID に紹介されたID(A列)を列挙しソートする
行2 = 1
For 行1 = 2 To 親子の行末
If 親子.Cells(行1, 2) = 今のID Then
作業用.Cells(行2, 階層) = 親子.Cells(行1, 1)
行2 = 行2 + 1
End If
Next 行1
行末 = 行2 - 1
列 = Chr(64 + 階層)
' 見やすくするため ID 番号順に並べ替え
If 行末 > 1 Then _
作業用.Range(列 & "1:" & 列 & 行末).Sort Key1:=作業用.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(表示行, 階層) = "" & 作業用.Cells(行2, 階層).Text
表示行 = 表示行 + 1
ツリー図2 作業用.Cells(行2, 階層).Text, 階層 + 1
Next 行2
End If
End Function
