Question

我想使用excel vba获取树视图。我有很多String喜欢这个

      /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

enter image description here

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

enter image description here

<强> CODE ：

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”列中。您必须适当更改代码以满足您的需求。在我的代码中，我刚刚硬编码了要在treeview中显示的拾取单元格。您需要根据自己的需要进行修改。

<强>声明：

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

<强>步骤：

将您的数据放入“A”列。（测试我的代码。根据需要稍后修改）
转到Developer标签，然后点击Design Mode。然后单击工具栏上的Insert按钮。
点击more...图标。右下角的那个。这将打开More Controls对话框。
寻找Microsoft TreeView Control, Version 6。选择该项并单击“确定”。
TreeView Control将添加到工作表中。双击它，它将打开代码窗口。

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

（将代码中的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（或您认为适合您的任何内容）。 enter image description here

7。添加其他按钮。这次将其与Sheet1.Button2_Click绑定，并将其标题设置为Clear

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

9。现在点击Fill TreeView，它应该填充TreeView中的文件名。 enter image description here

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

从字符串的VBA树视图

4 个答案: