字符串中的 VBA 树视图

VBA Tree View from string

提问by Sai Ye Yan Naing Aye

I would like to get tree view using excel vba.I have many String likes this

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

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

and I would like to make tree veiw in excel sheet using vba.My requirement is

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

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

So how should I define it?Please share me some ideas or links.I'm very new to vba.

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

回答by Siddharth Rout

Further to the recent edit, let's say your worksheet looks like this. Note that I created some dummy samples to demonstrate duplicate sub folders.

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

/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

Paste the below code in a module and run it. The output will be generated in a new sheet.

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

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

Disclaimer: I have not done any checks for /. Please either ensure that the data has /or put an extra line to check for /using Instrelse you will get an error when you run the code.

免责声明：我没有对/. 请确保数据具有/或添加额外的行来检查是否/使用，Instr否则在运行代码时会出现错误。

回答by Pradeep Kumar

Here is something from me.

这是我的东西。

Though you will still have to do some work yourself, which you can do easily. Assuming that your file paths are in "A" column. You will have to change the code appropriately to suit your needs. In my code, I have just hardcoded which cells to pickup to show in treeview. You will need to modify according to your needs.

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

DISCLAIMER:

免责声明：

The solution provided below is intended only for personal use. This solution is not feasible in case you are planning to distribute your Excel file. Also, your PC should have comctl32.ocx registered (which should be if you have VB6 runtime installed)

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

Steps:

脚步：

1. Put your data in "A" column. (to test my code. modify later as per your need)

2. Goto Developertab, and click Design Mode. Then click the Insertbutton on toolbar.

3. Click the more...icon. The one in the bottom right corner. This will open More Controlsdialog.

4. Look for Microsoft TreeView Control, Version 6. Select that and click OK.

5. A TreeView Control will be added to the sheet. Double click that and it will open the code window.

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

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

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

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

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

Paste the following code in code window.

在代码窗口中粘贴以下代码。

(Replace TreeView31in the code with the name of your 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.On Developers tab, click the Insertbutton on toolbar again and add a Buttoncontrol (the one in the top left corner). Add it to your sheet, and it will automatically popup Assign Macrodialog. Select Sheet1.Button1_Clickfrom the list. And rename the caption to Fill TreeView(or whatever you think appropriate for you).

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

7.Add another button. This time bind it with Sheet1.Button2_Clickand set its caption to Clear

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

8.Click the Design Modebutton on toolbar again to turn it off.

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

9.Now click the Fill TreeViewand it should fill your filenames in the TreeView.

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

回答by Hubisan

Was looking for something with a hierarchy to try out some recursive stuff. Here is my solution for this question:

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

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

回答by L42

ok assuming your data is in Column A, try this:

好的，假设您的数据在 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

Hope this get's you started somehow.

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