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
Reply With Quote
