来自字符串的 VBA 树视图

Question

我想使用 excel vba 获取树视图。我有很多这样的字符串

      /folderOne/fileOne
      /folderTwo/fileThree
      /folderOne/fileTwo
      /folderThree/fileFour
      /folderTwo/subFolderTwo
      /folderThree/subFolderThree/fileFive

我想使用 vba 在 excel 表中制作树视图。我的要求是

     folderOne
         L fileOne
         L fileTwo
     folderTwo
         L fileThree
     folderThree
         L fileFour
         subFolderThree
               L fileFive

那么我应该如何定义它？请分享一些想法或链接。我对 vba 很陌生。

Answer 1

除了最近的编辑，假设您的工作表如下所示。请注意，我创建了一些虚拟示例来演示重复的子文件夹。

/branches/test
/branches/test/link.txt
/branches/test/Test1/link.txt
/branches/testOne
/tags
/trunk
/trunk/test/Test1/link.txt
/trunk/testing
/trunk/testing/link.txt
/trunk/testOne

将以下代码粘贴到模块中并运行它。输出将在新工作表中生成。

代码：

Option Explicit

Const MyDelim As String = "#Sidz#"

Sub Sample()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim MyAr As Variant, TempAr As Variant
    Dim LRow As Long, lCol As Long
    Dim i As Long, j As Long, k As Long, r As Long, Level As Long
    Dim delRange As Range
    Dim sFormula As String, stemp1 As String, stemp2 As String

    On Error GoTo Whoa

    Application.ScreenUpdating = False

    '~~> Set this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    ws.Columns(1).Sort Key1:=ws.Range("A1"), _
    Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
    MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

    LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    MyAr = ws.Range("A1:A" & LRow).Value

    Set wsNew = ThisWorkbook.Sheets.Add

    r = 1: k = 2

    With wsNew
        For i = LBound(MyAr) To UBound(MyAr)
            TempAr = Split(MyAr(i, 1), "/")
            Level = UBound(TempAr) - 1
            .Range("A" & r).Value = TempAr(1)

            For j = 1 To Level
                r = r + 1
                .Cells(r, k).Value = Split(MyAr(i, 1), "/")(j + 1)
                k = k + 1
            Next j
            r = r + 1
            k = 2
        Next

        LRow = LastRow(wsNew)
        lCol = LastColumn(wsNew)

        For i = LRow To 1 Step -1
            If Application.WorksheetFunction.CountA(.Range(.Cells(i, 2), .Cells(i, lCol))) = 0 And _
               Application.WorksheetFunction.CountIf(.Columns(1), .Cells(i, 1)) > 1 Then
                .Rows(i).Delete
            End If
        Next i

        LRow = LastRow(wsNew)

        For i = 2 To LRow
            If .Cells(i, 1).Value = "" And .Cells(i - 1, 1).Value <> "" Then _
            .Cells(i, 1).Value = .Cells(i - 1, 1).Value
        Next i

        For i = 2 To LRow
            For j = 2 To (lCol - 1)
                If .Cells(i, j).Value = "" And .Cells(i - 1, j).Value <> "" And _
                .Cells(i, j - 1).Value = .Cells(i - 1, j - 1).Value Then _
                .Cells(i, j).Value = .Cells(i - 1, j).Value
            Next j
        Next i

        lCol = LastColumn(wsNew) + 1

        For i = 1 To LRow
            sFormula = ""
            For j = 1 To (lCol - 1)
                sFormula = sFormula & "," & .Cells(i, j).Address
            Next j
            .Cells(i, lCol).Formula = "=Concatenate(" & Mid(sFormula, 2) & ")"
        Next i

        .Columns(lCol).Value = .Columns(lCol).Value

        For i = LRow To 2 Step -1
            If Application.WorksheetFunction.CountIf(.Columns(lCol), .Cells(i, lCol)) > 1 Then
                .Rows(i).Delete
            End If
        Next i

        .Columns(lCol).Delete
        lCol = LastColumn(wsNew) + 1
        LRow = LastRow(wsNew)

        For i = LRow To 2 Step -1
            For j = lCol To 2 Step -1
                If .Cells(i, j).Value <> "" And .Cells(i, j).Value = .Cells(i - 1, j).Value Then
                    For k = 2 To (j - 1)
                        stemp1 = stemp1 & MyDelim & .Cells(i, k).Value
                        stemp2 = stemp2 & MyDelim & .Cells(i - 1, k).Value
                    Next k
                    stemp1 = Mid(stemp1, Len(MyDelim) + 1)
                    stemp2 = Mid(stemp2, Len(MyDelim) + 1)

                    If UCase(stemp1) = UCase(stemp2) Then
                        .Range(.Cells(i, 1), .Cells(i, k)).ClearContents
                        Exit For
                    End If
                End If
            Next j
        Next i


        For i = LRow To 2 Step -1
            If Application.WorksheetFunction.CountIf(.Columns(1), _
            .Cells(i, 1).Value) > 1 Then .Cells(i, 1).ClearContents
        Next i

        .Cells.EntireColumn.AutoFit
    End With

LetsContinue:
    Application.ScreenUpdating = True
    Exit Sub
Whoa:
    MsgBox Err.Description
End Sub

Function LastRow(wks As Worksheet) As Long
    LastRow = wks.Cells.Find(What:="*", _
                After:=wks.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
End Function

Function LastColumn(wks As Worksheet) As Long
    LastColumn = wks.Cells.Find(What:="*", _
                After:=wks.Range("A1"), _
                Lookat:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column
End Function

免责声明：我没有对/ 进行任何检查。请确保数据有/ 或使用Instr 多写一行以检查/，否则运行代码时会出错。

Answer 2

好的，假设您的数据在 A 列，试试这个：

Option Explicit

Sub test()

Dim rng As Range, cel As Range

Set rng = ThisWorkbook.Sheets("Sheet1").Range("A1", _
            ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Address)

rng.TextToColumns rng.Range("A1"), , , , , , , , True, "/"

Set rng = ThisWorkbook.Sheets("Sheet1").Range("B1", _
            ThisWorkbook.Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Address)

For Each cel In rng
    If cel.Row <> 1 Then If cel.Value = cel.Offset(-1, 0).Value Then cel.ClearContents
Next

End Sub

希望这能让你以某种方式开始。

Answer 3

这是我的东西。

虽然您仍然需要自己做一些工作，但您可以轻松完成。 假设您的文件路径位于“A”列中。您将不得不适当地更改代码以满足您的需要。在我的代码中，我刚刚硬编码了要在树视图中显示的单元格。您需要根据自己的需要进行修改。

免责声明：

下面提供的解决方案仅供个人使用。如果您计划分发 Excel 文件，此解决方案不可行。此外，您的 PC 应该注册了 comctl32.ocx（如果您安装了 VB6 运行时应该是）

步骤：

1. 将您的数据放入“A”列。 （测试我的代码。稍后根据您的需要修改）

2. 转到Developer 选项卡，然后单击Design Mode。然后单击工具栏上的Insert 按钮。

3. 单击more... 图标。右下角的那个。这将打开More Controls 对话框。

4. 寻找Microsoft TreeView Control, Version 6。选择它并单击确定。

5. 将向工作表添加 TreeView 控件。双击它，它将打开代码窗口。

将以下代码粘贴到代码窗口中。

（将代码中的TreeView31 替换为您的TreeView 控件的名称。）

Sub Button1_Click()
    LoadTreeView TreeView31
End Sub

Sub Button2_Click()
    TreeView31.Nodes.Clear
End Sub

Sub LoadTreeView(TV As TreeView)
    Dim i As Integer, RootNode As Node
    TV.Nodes.Clear
    Set RootNode = TV.Nodes.Add(, , "ROOT", "ROOT")
    RootNode.Expanded = True
    For i = 1 To 5
        AddNode TV, RootNode, Cells(i, 1)
    Next
End Sub

Private Sub AddNode(TV As TreeView, RootNode As Node, Path As String)
    Dim ParentNode As Node, NodeKey As String
    Dim PathNodes() As String

    On Error GoTo ErrH
    PathNodes = Split(Path, "/")
    NodeKey = RootNode.Key
    For i = 1 To UBound(PathNodes)
        Set ParentNode = TV.Nodes(NodeKey)
        NodeKey = NodeKey & "/" & PathNodes(i)
        TV.Nodes.Add ParentNode, tvwChild, NodeKey, PathNodes(i)
        ParentNode.Expanded = True
    Next

    Exit Sub
ErrH:
    If Err.Number = 35601 Then
        Set ParentNode = RootNode
        Resume
    End If
    Resume Next
End Sub

6. 在“开发者”选项卡上，再次单击工具栏上的Insert 按钮并添加一个Button 控件（左上角的那个）。将其添加到您的工作表中，它将自动弹出Assign Macro 对话框。从列表中选择Sheet1.Button1_Click。并将标题重命名为Fill TreeView（或您认为适合您的任何名称）。

7. 添加另一个按钮。这次将它与Sheet1.Button2_Click 绑定并将其标题设置为Clear

8.再次点击工具栏上的Design Mode按钮将其关闭。

9. 现在单击Fill TreeView，它应该会在 TreeView 中填充您的文件名。

Answer 4

正在寻找具有层次结构的东西来尝试一些递归的东西。这是我对这个问题的解决方案：

Sub callTheFunction()
    '"A1:A6" = range with the values, "A10" = first cell of target range, "/" = delimiter
    Call createHierarchy(Range("A1:A6"), Range("A10"), "/")
End Sub

Sub createHierarchy(rngSource As Range, rngTarget As Range, strDelimiter As String)
    Dim dic As Object, rng As Range
    Set dic = CreateObject("scripting.dictionary")
    For Each rng In rngSource
        addValuesToDic dic, Split(rng.Value, strDelimiter), 1
    Next
    writeKeysToRange dic, rngTarget, 0, 0
End Sub

Sub addValuesToDic(ByRef dic As Object, ByVal avarValues As Variant, i As Long)
    If Not dic.Exists(avarValues(i)) Then
        Set dic(avarValues(i)) = CreateObject("scripting.dictionary")
    End If
    If i < UBound(avarValues) Then addValuesToDic dic(avarValues(i)), avarValues, i + 1
End Sub

Sub writeKeysToRange(dic As Object, rngTarget As Range, _
ByRef lngRowOffset As Long, ByVal lngColOffset As Long)
    Dim varKey As Variant
    For Each varKey In dic.keys
        'adds "L    " in front of file if value is like "file*"
        rngTarget.Offset(lngRowOffset, lngColOffset) = IIf(varKey Like "file*", "L    " & varKey, varKey)
        lngRowOffset = lngRowOffset + 1
        If dic(varKey).Count > 0 Then
            writeKeysToRange dic(varKey), rngTarget, lngRowOffset, lngColOffset + 1
        End If
    Next
End Sub