创建树状目录结构

Option Explicit

Private Sub CommandButton1_Click()
 Dim intCount As Integer, strNodes As String, lngSelCount As Long
 lngSelCount = 0
 
 If TreeView1.SelectedItem Is Nothing Then
 
 Else
   With TreeView1.SelectedItem
     strNodes = "索引: " & .Index & Chr(13) & "单元格区域: " & .Key & Chr(13) & "任务: " & .text
   End With
   MsgBox Chr(13) & strNodes & Chr(13), , "已选取任务"
 End If
End Sub

Private Sub CommandButton2_Click() 
  Unload UserForm1
End Sub

Private Sub CommandButton3_Click()
  With TreeView1
    .Nodes.Clear
  End With
End Sub

Private Sub CommandButton4_Click()
  Dim nPnode As Node
  Dim cRng As Range
  Const cRoot As String = "$B$4"
 
  With TreeView1
    .Nodes.Clear
    Set nPnode = .Nodes.Add(, ,Range(cRoot).Address, Sheet1.Range(cRoot).Value)
    nPnode.Expanded = True
    For Each cRng In Sheet1.Range(cRoot).CurrentRegion
      If cRng.Value <> vbNullString And cRng.Address <> cRoot Then
        Set nPnode = .Nodes(cRng.Offset(, -1).End(xlUp).Address)
        If nPnode Is Nothing Then
          MsgBox "错误: 父节点" & cRng.Offset(, -1).End(xlUp).Value & " 没有找到...", vbExclamation, "错误"
          Exit Sub
        End If
      .Nodes.Add nPnode, tvwChild, cRng.Address, cRng.Value
      If Err.Number <> 0 Then
        MsgBox "错误: 节点" & cRng.Value & "重复. 所有节点描述必须唯一", vbExclamation, "错误"
        Exit Sub
      End If
     End If
   Next
   With .Nodes(Range(cRoot).Address)
     .Selected = True
     .EnsureVisible
   End With
   .Style = tvwTreelinesPlusMinusText
 End With
End Sub

Sub A_Unique_B()
  Dim X
  Dim objDict As Object
  Dim lngRow As Long
  Set objDict = CreateObject("Scripting.Dictionary")
  X = Application.Transpose(Range([H1], Cells(Rows.Count, "H").End(xlUp)))
  For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
  Next
  Range("H1:H" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub

Private Sub UserForm_Initialize()
  Dim nPnode As Node
  Dim cRng As Range
  Const cRoot As String = "$B$4"
 
  With TreeView1
    .Nodes.Clear
    Set nPnode = .Nodes.Add(, , Range(cRoot).Address, Sheet1.Range(cRoot).Value)
    nPnode.Expanded = True
    For Each cRng In Sheet1.Range(cRoot).CurrentRegion
      If cRng.Value <> vbNullString And cRng.Address <> cRoot Then
        Set nPnode = .Nodes(cRng.Offset(, -1).End(xlUp).Address)
        If nPnode Is Nothing Then
          MsgBox "错误: 父节点" & cRng.Offset(, -1).End(xlUp).Value & " 没有找到...", vbExclamation, "错误"
          Exit Sub
        End If
        .Nodes.Add nPnode, tvwChild, cRng.Address, cRng.Value
        If Err.Number <> 0 Then
          MsgBox "错误: 节点" & cRng.Value & " 重复. 所有节点描述必须唯一", vbExclamation, "错误"
          Exit Sub
        End If
      End If
    Next
    With .Nodes(Range(cRoot).Address)
      .Selected = True
      .EnsureVisible
    End With
    .Style = tvwTreelinesPlusMinusText
   End With
 End Sub