Results 1 to 20 of 24

Thread: Solved: Creating a data tree in the worksheet

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Regular
    Joined
    Dec 2008
    Posts
    86
    Location

    Solved: Creating a data tree in the worksheet

    Hello everybody
    Hope everybody is doing fine here.
    i am haveing a set of data in a format in which one value contains a certain set of values. i want to create a tree of those data by clicking on a single button. The data should appear in the form of trees with the parent node having a plus sign in front of them.
    here is my module code:
    [vba]
    Option Explicit
    Sub MakeFamilyTree()
    Dim arrName As Variant
    Dim arrParent As Variant
    Dim arrMatrix() As Variant
    Dim arrTemp As Variant
    Dim elm As Variant
    Dim i As Long, j As Variant
    Dim ret As Variant
    Dim nodX As Node
    Dim bExists As Boolean
    'Reset Tree View control
    UserForm1.TreeView1.Nodes.Clear
    'Get data from the worksheet as an array
    With Sheets("BOM_Formatted").Range(Sheets("BOM_Formatted").[D2], Sheets("BOM_Formatted").[D65536].End(xlUp))
    arrName = .Value
    arrParent = .Offset(, 1).Value
    End With
    'Sorting in an array
    ReDim arrMatrix(1 To UBound(arrName), 1 To 1)
    For Each elm In arrParent
    i = i + 1
    ret = Application.Match(elm, arrName, 0)
    If IsError(ret) Then
    arrMatrix(i, 1) = arrName(i, 1)
    Else
    j = 3
    ReDim Preserve arrMatrix(1 To UBound(arrMatrix), 1 To j)
    arrMatrix(i, 1) = arrName(i, 1)
    arrMatrix(i, 2) = elm
    arrMatrix(i, 3) = arrParent(ret, 1)
    Do
    ret = Application.Match(arrParent(ret, 1), arrName, 0)
    If IsError(ret) Then Exit Do
    If arrParent(ret, 1) = "" Then Exit Do
    j = j + 1
    ReDim Preserve arrMatrix(1 To UBound(arrMatrix), 1 To j)
    arrMatrix(i, j) = arrParent(ret, 1)
    Loop
    End If
    Next
    arrTemp = CustomTranspose(arrMatrix)
    'Let's add each data to nodes
    For i = 1 To UBound(arrTemp)
    For j = 1 To UBound(arrTemp, 2)
    If Not IsEmpty(arrTemp(i, j)) Then
    With UserForm1.TreeView1
    bExists = False
    For Each elm In .Nodes
    If elm = arrTemp(i, j) Then bExists = True
    Next
    If Not bExists Then
    If j = " " Then
    Set nodX = .Nodes.Add(, , arrTemp(i, j), arrTemp(i, j), _
    Image:=GetInfo(arrTemp(i, j), True))

    'Else
    ' Set nodX = .Nodes.Add(arrTemp(i, j - 1), tvwChild, arrTemp(i, j), arrTemp(i, j), _
    ' Image:=GetInfo(arrTemp(i, j), True))
    End If
    'nodX.Expanded = True
    End If
    End With
    End If
    Next
    Next
    End Sub

    Function CustomTranspose(ByVal buf As Variant) As Variant
    'Transpose an order of an array from Parent to Child
    Dim arrTemp() As Variant
    Dim i As Long, j As Long, k As Long
    ReDim arrTemp(LBound(buf) To UBound(buf), LBound(buf, 2) To UBound(buf, 2))
    For i = 1 To UBound(buf)
    k = 0
    For j = UBound(buf, 2) To 1 Step -1
    If Not IsEmpty(buf(i, j)) Then
    k = k + 1
    arrTemp(i, k) = buf(i, j)
    End If
    Next
    Next
    CustomTranspose = arrTemp
    End Function
    Function GetInfo(sName, bAorD) As String
    'Returns appropreate image
    Dim rFound As Range
    Set rFound = Sheet1.Columns(1).Find(sName, lookat:=xlWhole)
    If rFound Is Nothing Then
    GetInfo = "none"
    Else
    GetInfo = IIf(bAorD, rFound.Offset(, 2).Value, rFound.Offset(, 3).Value)
    End If
    End Function

    [/vba]
    here is my userform code:
    [vba]
    Private Sub UserForm_Initialize()

    'Purpose: Load userform with desired defaults
    'Set control defaults
    With Me


    .TreeView1.LineStyle = tvwRootLines
    End With
    'Populate the Treeview
    Call TreeView_Populate
    End Sub
    Private Sub TreeView_Populate()

    'Purpose: Populate the treeview control
    Dim ws As Worksheet
    Dim rngFormula As Range
    Dim rngFormulas As Range
    With Me.TreeView1.Nodes
    'Clear TreeView control
    .Clear
    For Each ws In ActiveWorkbook.Worksheets
    'Add worksheet nodes
    .Add Key:=ws.Name, Text:=ws.Name
    'Check if any formulas in worksheet
    On Error Resume Next
    Set rngFormulas = ws.Cells.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    'Add formula cells
    If Not rngFormulas Is Nothing Then
    For Each rngFormula In rngFormulas
    .Add relative:=ws.Name, _
    relationship:=tvwChild, _
    Key:=ws.Name & "," & rngFormula.Address, _
    Text:="Range " & rngFormula.Address
    Next rngFormula
    End If
    'Release the range for next iteration
    Set rngFormulas = Nothing
    Next ws
    End With
    End Sub


    [/vba]
    however after executing i get a tree which contain all the sheets as branches instead of the data.
    I am also attaching my file here. in the file the sheet name "BOM_Formatted" i have tabbed the data values so as to appear as a tree(for illustration.)
    i hope to get some useful help here as before.
    Thank you
    Last edited by kishlaya; 01-20-2009 at 07:06 AM. Reason: code update

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •