GDIplusCODE


Sub treeDiagram()
  Dim targetRange As Range, firstRange As Range
  Dim myLevel As Long
  
  With Sheets("データ")
    Set targetRange = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
  End With
  Set targetRange = targetRange.Offset(1, 0).Resize(targetRange.Rows.Count - 1, targetRange.Columns.Count)
  '転機先シートの値をクリアし、最初のセルに値をセット
  Sheets("経路図").UsedRange.ClearContents
  Set firstRange = Sheets("経路図").Range("A1")
  '親の親の値を-と決めて、処理開始
  firstRange.Value = "-"
  Call treeSub(firstRange, targetRange)
End Sub

'親ノード名を転記したセル、元データ範囲Range
Private Sub treeSub(myParentRange As Range, targetRange As Range)
  Dim myCollection As New Collection
  Dim i As Long, j As Long
  Dim firstTimeFlag As Boolean
  
  'parentNameを親に持つ子の値のリストを取得
  Set myCollection = getNodeList(myParentRange.Value, targetRange)
  firstTimeFlag = True
  For i = 1 To myCollection.Count
    With myParentRange
      '都度新しい行を足して処理して行くのがミソ
      .Offset(1, 0).EntireRow.Insert
      '縦線を補う
      For j = 1 To .Column - 1
        Select Case .Offset(2, -j).Value
          Case "└", "├", "│"
            .Offset(1, -j).Value = "│"
        End Select
      Next j
      If .Column > 1 Then '一列めは罫線を引かない
        If firstTimeFlag Then
            .Offset(1, 0).Value = "└"
            firstTimeFlag = False
        Else
            .Offset(1, 0).Value = "├"
        End If
      End If
      '子の値の転記
      .Offset(1, 1).Value = myCollection.Item(i)
      '再帰コール
      Call treesub(.Offset(1, 1), targetRange)
    End With
  Next i
End Sub

'ある値を親に持つノードのリストを与える
Private Function getNodeList(parentName As String, targetRange As Range) As Collection
  Dim c As Range
  Dim firstAddress As String
  
  Set getNodeList = New Collection
  With targetRange.Columns(2)
      Set c = .Find(parentName, LookIn:=xlValues, lookat:=xlWhole)
      If Not c Is Nothing Then
          firstAddress = c.Address
          Do
              getNodeList.Add c.Offset(0, -1).Value
              Set c = .FindNext(c)
          Loop While Not c Is Nothing And c.Address <> firstAddress
      End If
  End With
End Function
TreeViewの様な階層図を描く
