VBA Tree View from string

Question

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

      /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

     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.

Answer 1

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

Answer 2

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 Instr else you will get an error when you run the code.

Answer 3

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.

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)

Steps:

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

2. Goto Developer tab, and click Design Mode. Then click the Insert button on toolbar.

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

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.

Paste the following code in code window.

(Replace TreeView31 in the code with the name of your TreeView control.)

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 Insert button on toolbar again and add a Button control (the one in the top left corner). Add it to your sheet, and it will automatically popup Assign Macro dialog. Select Sheet1.Button1_Click from the list. And rename the caption to Fill TreeView (or whatever you think appropriate for you).

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

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

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

Answer 4

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

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.