none
Treeview population loop too long RRS feed

  • Question

  • Hi all,

    I have a macro that takes a list of parent and child items from a table, and then populates the treeview1 control on a userform.  It all works fine, but once there are large number of items to add(+10000) it slows down.

    I believe this is due to my poor and inefficient coding.  I've worked on speeding it up over the years, but have resolved myself to the fact that really optimising its performance is beyond my VBA capabilities.

    A brief outline of the code...

    Sub Hierarchy() is executed and either builds the tree (no errors), tells the user building the tree is unavoidable (levels are yet to be determined), or lets the user know there are some errors in the structure and asks the user how to proceed.

    Sub DetLevel() is called depending on the selection and tests the list for some errors, then loops through each parent/child paring to determine the level in the tree child item belongs.  These levels are written to Table1

    Sub BuildTree() is called and we now loop through each Table1 to place the item in the appropriate spot on the treeview control

    If anyone is willing to take a look and assist me in understanding some of the improvements possible, I would be very appreciative.

    Cheers

    Brad

    https://gyazo.com/bad5c553e8d36734c3040d015e4ced61 (picture of sheet1)

    Public myRange As Range
    
    Sub Hierarchy()
        Dim lngRow As Long
        Dim strNodeKey As String
        Dim strRelativeNode As String
        Dim strText As String
        Dim Duration As Long
        Dim StartTime, EndTime As Date
        Dim sw As StopWatch
        Set sw = New StopWatch
        
            ' unprotect the sheet and set the equipment table as the myRange
            Application.ScreenUpdating = False
            Set myRange = Range(Sheets(1).ListObjects("Table1"))
                
            ' check if any cells in column 4 are blank, if they are we're building from scratch
            For Each cell In myRange.Columns(4).Cells
                If cell.Value = "" Then
                    MsgBox ("Sorry, the hierarchy must be built." & vbCrLf & _
                        "This may take some time depending on the number of equipment items." _
                        & vbCrLf & vbCrLf & "Please be patient.")
                    'Application.Cursor = xlWait
                    Call DetLevel
                    Call BuildTree
                    Exit Sub
                End If
            Next cell
            
            ' no cells blank, but some have errors, what do we do now?
            For Each cell In myRange.Columns(4).Cells
                If cell.Value Like "Error*" Then
                    output = MsgBox("Equipment list contains errors." & vbCrLf & vbCrLf & _
                        "~~> Use 'Abort' to exit the show process." & vbCrLf & _
                        "~~> Use 'Retry' to rebuild the hierarchy." & vbCrLf & _
                        "~~> Use 'Ignore' to build with current list." _
                        , vbAbortRetryIgnore, "Build Hierarchy?")
                    If output = 3 Then 'Abort & exit this build process
                        UserForm2.Hide 'and maybe I'll fix those errors
                        Exit Sub
                    End If
                    If output = 4 Then 'Retry
                        MsgBox ("Hierarchy must be built." & vbCrLf & _
                        "This may take some time, please be patient.")
                        Application.Cursor = xlWait
                        Call DetLevel  'lets rebuild that sucker cause I have time to spare
                        Call BuildTree
                        Exit Sub
                    End If
                    If output = 5 Then 'Ignore
                        Call BuildTree 'errors, what errors...
                        Exit Sub
                    End If
                End If
            Next cell
        Call BuildTree 'error free so show it
        Exit Sub
    End Sub
    
    Sub DetLevel()
    ' Declare Variables
        Dim hCount As Integer
        Dim cell As Range
        Dim Duration As Long
        Dim StartTime, EndTime As Date
        Dim sw As StopWatch
        Set sw = New StopWatch
        
        Application.ScreenUpdating = False
    ' Set Variables
        lvl = 1
        toAdd = myRange.Rows.Count
            
    ' Clear Levels column of values
        myRange.Columns(4).ClearContents
    
    'Error Checking
    'still nedd to check for duplicate children here
    
        'Check for Parent that has not been listed as Asset
        'StartTime = Now 'detlevel error loop
        sw.StartTimer
        For Each Par In myRange.Columns(1).Cells
            If Par.Value <> "" Then
                If Par.Value = Par.Offset(0, 1).Value Then
                    Par.Offset(0, 3).Value = "Error - Parent and Asset have the same identifier"
                    toAdd = toAdd - 1
                End If
                If Par.Offset(0, 1).Value = "" Then
                    Par.Offset(0, 3).Value = "Error - Parent has no child asset"
                    toAdd = toAdd - 1
                End If
                Set IsItThere = myRange.Columns(2).Find(what:=Par.Value, LookAt:=xlWhole)
                If IsItThere Is Nothing Then
                    Par.Offset(0, 3).Value = "Error - Parent not listed as Asset"
                    toAdd = toAdd - 1
                End If
            End If
        Next Par
        
        Debug.Print "That took: " & sw.EndTimer & " milliseconds"
        EndTime = Now
        If StartTime <> "" Then
            Duration = DateDiff("s", CDate(StartTime), CDate(EndTime))
            MsgBox (Duration & " seconds runtime for detlevel error loop") ' tell me how long my selection took '12 Sec
        End If
       
    ' Set Level 1 - Assets that don't have parents
        'StartTime = Now 'detlevel root nodes loop
        sw.StartTimer
        
        For Each cell In myRange.Columns(1).Cells
            If cell.Value = "" Then
                cell.Offset(0, 3).Value = lvl
                toAdd = toAdd - 1
            End If
        Next cell
        
        Debug.Print "That took: " & sw.EndTimer & " milliseconds"
        EndTime = Now
        If StartTime <> "" Then
            Duration = DateDiff("s", CDate(StartTime), CDate(EndTime))
            MsgBox (Duration & " seconds runtime detlevel root nodes loop") ' tell me how long my selection took '0 sec
        End If
        
    ' Set rest
        'StartTime = Now 'detlevel child nodes loop
        sw.StartTimer
        
        Do While toAdd > 0
        'myRange.Select
            'x = 1
            'ColCount = myRange.Columns.Count
            'For Irow = 1 To RowCount
                'For Icol = 1 To ColCount
            '        If myRange(Irow, 6) = lvl Then
            '            ParValue = myRange(Irow, 4)
            '            For Each Equip In myRange.Columns(3) '(Irow, 3)
            '                If Equip.Text = ParValue Then
            '                    myRange(Irow, 6) = lvl + 1
            '                    toAdd = toAdd - 1
            '                End If
            '            Next Equip
            '        End If
                'Next Icol
            'Next Irow
            'lvl = lvl + 1
        'Loop
            
            For Each Level In myRange.Columns(4).Cells 'change to table and datarange?
                If Level.Value = lvl Then
                    'ParValue = myRange(x, 4).Value 'ParValue = myRange.Cells(x, 4).Value
                    ParValue = Level.Offset(0, -2).Value
                    For Each Equip In myRange.Columns(1).Cells
                        If Equip.Value = ParValue Then
                            'myRange(Equip).Offset(0, 3).Value = lvl + 1 'myRange.Cells(x, 6) = lvl + 1
                            Equip.Offset(0, 3).Value = lvl + 1
                            toAdd = toAdd - 1
                        End If
                    'x = x + 1
                    Next Equip
                End If
            'x = x + 1
            Next Level
            lvl = lvl + 1
        Loop
        
        Debug.Print "That took: " & sw.EndTimer & " milliseconds"
        EndTime = Now
        If StartTime <> "" Then
            Duration = DateDiff("m", CDate(StartTime), CDate(EndTime))
            MsgBox (Duration & " seconds runtime detlevel child nodes loop") ' tell me how long my selection took '255 sec
        End If
    
    ' sort by level
        ActiveWorkbook.Worksheets(1).ListObjects("Table1").Sort.SortFields _
            .Add Key:=Range("Table1[[#All],[Level]]"), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        With ActiveWorkbook.Worksheets(1).ListObjects("Table1").Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
    End Sub
    
    
    Sub BuildTree()
        Dim lngRow As Long
        Dim strNodeKey As String
        Dim strRelativeNode As String
        Dim strText As String
        Dim Duration As Long
        Dim StartTime, EndTime As Date
        Dim sw As StopWatch
        Set sw = New StopWatch
        
        UserForm2.Show False
        Application.ScreenUpdating = False
    
        'StartTime = Now ' buildtree loop 1
        sw.StartTimer
        With myRange
            For lngRow = 1 To .Rows.Count 'start at row 2 to avoid headers
                strNodeKey = .Cells(lngRow, 2) ' asset or Child value from column C on
                strRelativeNode = .Cells(lngRow, 1) ' parent value from column B
                strText = .Cells(lngRow, 3) 'description from Column D
                lev = .Cells(lngRow, 4) ' level from column E on Equipment Tab
                tvwChild = 4 ' determines the tree build structure
                    
                If Not lev Like "Error*" Then ' ignore error rows in the build
                    If strRelativeNode = "" Then
                        ' it's a root node
                        UserForm2.TreeView1.Nodes.Add , , strNodeKey, lev & "_" & strNodeKey & "_" & strText
                    Else
                        ' its a child node
                        UserForm2.TreeView1.Nodes.Add strRelativeNode, tvwChild, strNodeKey, lev & "_" & _
                            strNodeKey & "_" & strText
                    End If
                End If
            Next
        End With
        
        Debug.Print "That took: " & sw.EndTimer & " milliseconds"
    
        EndTime = Now
        If StartTime <> "" Then
            Duration = DateDiff("s", CDate(StartTime), CDate(EndTime))
            MsgBox (Duration & " seconds runtime for buildtree loop 1") ' tell me how long my selection took
        End If
        Application.ScreenUpdating = True
        
    End Sub
    
    Sub ClrLevel()
        Set myRange = Range(Sheets(1).ListObjects("Table1"))
        myRange.Columns(4).ClearContents
    End Sub
    
    Sub FindNode()
    
        UserForm2.TreeView1.SetFocus
        fText = UserForm2.TextBox1.Text
    
        For i = 1 To UserForm2.TreeView1.Nodes.Count
            If InStr(LCase(UserForm2.TreeView1.Nodes.Item(i).Text), LCase(fText)) > 0 Then
                UserForm2.TreeView1.Nodes.Item(i).Selected = True
                Exit Sub
            End If
        Next i
        MsgBox ("Sorry, text not found.")
        
    End Sub



    • Edited by _Brad_C_ Tuesday, February 2, 2016 4:03 PM picture link added
    Tuesday, February 2, 2016 4:00 PM

Answers

  • Hi Brad,

    I've checked your file, at first when I open it I get this errors:

    For what reason ever, I don't know. Anyway.

    After that I've taken a look into the VBA codes, added Option Explicit at the top of the module, declared the missing variables, comment out some code to fix some errors... till it runs without issues.

    I've disabled your timing code, because GetTickCount is not precisely enough to get accurate timings.
    I use QueryPerformanceCounter instead, you can disable that code when you set #Const Develop = False

    The complete time for Sub Hierarchy after that: around 0.06 seconds
    You can run this code when you set #Const Version = 1

    At 2 points you can use SpecialCells and a data array instead of a FOR EACH and access each cell.
    The complete time for Sub Hierarchy after that: around 0.035 seconds
    You can run this code when you set #Const Version = 2

    That means the code is speed up around 40%.

    Here is your modified file:
    https://dl.dropboxusercontent.com/u/35239054/Samples/2074d16e-6009-4b07-b2d8-7eb943e2a587.xlsm

    Andreas.

    • Marked as answer by _Brad_C_ Thursday, February 4, 2016 12:12 PM
    Wednesday, February 3, 2016 3:45 PM

All replies

  • https://gyazo.com/bad5c553e8d36734c3040d015e4ced61 (picture of sheet1)

    Please upload your file "Hierachy Test.xlsm" on an online file hoster like www.dropbox.com and post the download link here.

    So we have a ready to go test scenario.

    And add another sheet with a table with at min. 10.000 rows of data that can be loaded without errors, so we can test which part can be made faster.

    Andreas.

    Tuesday, February 2, 2016 4:47 PM
  • Thanks Andreas,

    File from OneDrive

    Cheers

    Brad




    • Edited by _Brad_C_ Saturday, February 6, 2016 4:05 AM
    Tuesday, February 2, 2016 11:04 PM
  • Hi Brad,

    I've checked your file, at first when I open it I get this errors:

    For what reason ever, I don't know. Anyway.

    After that I've taken a look into the VBA codes, added Option Explicit at the top of the module, declared the missing variables, comment out some code to fix some errors... till it runs without issues.

    I've disabled your timing code, because GetTickCount is not precisely enough to get accurate timings.
    I use QueryPerformanceCounter instead, you can disable that code when you set #Const Develop = False

    The complete time for Sub Hierarchy after that: around 0.06 seconds
    You can run this code when you set #Const Version = 1

    At 2 points you can use SpecialCells and a data array instead of a FOR EACH and access each cell.
    The complete time for Sub Hierarchy after that: around 0.035 seconds
    You can run this code when you set #Const Version = 2

    That means the code is speed up around 40%.

    Here is your modified file:
    https://dl.dropboxusercontent.com/u/35239054/Samples/2074d16e-6009-4b07-b2d8-7eb943e2a587.xlsm

    Andreas.

    • Marked as answer by _Brad_C_ Thursday, February 4, 2016 12:12 PM
    Wednesday, February 3, 2016 3:45 PM
  • Hi Andreas,

    Thank you.  This certainly is very nice and shows I have quite a lot to learn.I'm not sure what the error is at file opening.  As I understand it, it has something to do with the sorting a table.

    I noticed that the time consuming Do While loop in the DetLevel() sub has remained unchanged.

      Do While toAdd > 0
        For Each Level In myRange.Columns(4).Cells
          If Level.Value = lvl Then
            ParValue = Level.Offset(0, -2).Value
            For Each Equip In myRange.Columns(1).Cells
              If Equip.Value = ParValue Then
                Equip.Offset(0, 3).Value = lvl + 1
                toAdd = toAdd - 1
              End If
            Next Equip
          End If
        Next Level
        lvl = lvl + 1
      Loop

    It prompts me to ask if this is as good as it can be? Is there better way to build the treeview with the type of data I have?  Do I need to expend so much time determining the level?  I'm not that attached to that data.

    Thanks Again.

    Brad



    Thursday, February 4, 2016 12:04 PM
  • It prompts me to ask if this is as good as it can be?

    I can't answer that for sure. Because it depends on so many things what is "the best way".
    And if you ask 10 programmers what is the best way, you get 10 different answers.

    IMHO it is not possible to "rebuild" a tree in the way you do, because you can not be 100% sure that the structure is correct afterwards. So I would never care about the data, read it as is and show it as is.

    A similar problem is a cascading combo box, which is used more often as a Treeview.

    There are different solutions out there to get it to work in Excel, but I found all relatively complicated to setup.
    And the biggest problem was always the start: How to setup the data in a way that is a) easy for the user and b) reflects the result as best what you can see on your Userform and c) is easy to read and to write.

    So I came up with this solution:
    https://dl.dropboxusercontent.com/u/35239054/Cascade%20ComboBox.xls

    Have a look into the sheet Setup, doesn't look like a "Treeview in a sheet"?

    I don't say that this would be better for you, it's just another idea.

    Andreas.

    Thursday, February 4, 2016 2:23 PM
  • Thanks Again Andreas,

    This solution isn't really suitable for my situation.  My data will always be listed in columns according the parent and child.  Other columns are added as required (like description) but the information in them always relates to the child in the relationship.

    The next thing I would like to do is allow dragging and dropping on the treeview control.  The drop event should update the parent value in the table to the node on which it Is dropped.  In concept this appears easy to accomplish however I've not really had any success.

    Cheers

    Brad

    Thursday, February 4, 2016 3:20 PM
  • I'm haven't followed all the detail here but not sure what the problem is. In a quick look at your file I simply added a button to your form with this

    Private Sub CommandButton4_Click()
    Dim r As Long
    Dim tv As TreeView
    Dim nd As MSComctlLib.Node
    Dim arrData
    
        arrData = ThisWorkbook.Worksheets("Sheet1").Range("Table1")
        Set tv = Me.TreeView1
    
        tv.Style = tvwPlusMinusText
        tv.Indentation = 12
    
        Set nd = tv.Nodes.Add(, , arrData(1, 2), arrData(1, 3))
        nd.Expanded = True
        For r = 2 To UBound(arrData)
            Set nd = tv.Nodes.Add(arrData(r, 1), tvwChild, arrData(r, 2), arrData(r, 3))
            nd.Expanded = True
        Next
    
    End Sub

    It loaded in an eyeblink, I assume it gives the hierarchy you want but if not should be easy to adapt. 

    About Drag and Drop, whether or not its builtin approach would work will depend on what you want to drag to & from. You can 'roll your own' approach to drag from/to other userform controls but from cells is difficult, if that's what you mean.

    In passing, when I opened your file the reference to MSComCtl was broken, even after adding it I had to re-add the control on the form. If interested there's a VBA alternative. The free version would be slow to populate with 2000 nodes (seconds), though there is a non-free version due soon which should be as fast as the aX. (Disclaimer, I have an interest in this)

    Friday, February 5, 2016 10:47 AM
    Moderator
  • Thanks Peter,

    In summary I have a table that contains a list of parent and child items and I arrange them in a hierarchy on a treeview control.

    To do this I iterate through each child item and determine the level in the hierarchy at which it sits.  I then iterate through each level and place the child item in the tree.  As you can imagine this is time consuming when there are a large number of elements to iterate through. Andreas was fantastic, and helped me optimise my code.

    I tried as you suggested, and placed a button on the userform and ran the code you provided.  I get 2 user-defined type not defined errors on Dim tv As TreeView, and Dim nd As MSComctlLib.Node.  When I comment these line out, the code executes but only provides a flat list of the data in the table.

    Cheers

    Brad

    Saturday, February 6, 2016 4:02 AM
  • I assumed you were using the MSComCtl.ocx treeview so that's what I put on a form. As I mentioned when I opened the file the reference was broken and no treeview control on the form.

    With the  code exactly as posted the treeview populated as in this screenshot in an eye-blink. It's obviously not flat but is it as you'd expect?

    Saturday, February 6, 2016 9:41 AM
    Moderator
  • Hi Peter,

    Wow!

    At home I use MS Office 2016, however at work we still use 2010.  When I created the treeview form I did so at home then at work it behaved just as you described.  No treeview control appeared on the form. To fix the issue I added the 2010 treeview control and saved my file.  This also worked fine in the 2016 version so I believed the problem was no backward compatibility (2016 TV control doesn't appear in 2010 excel).

    Your code populates the treeview in a blink, and there is no need for time consuming loops.  You'll have to excuse my ignorance.  I don't understand how to tell if I'm using the MSComCtl.ocx treeview or some other treeview. Oops, that's not true, I guess I do.  I just need to pay attention to the location of the control I'm using.

    How would I make your code compatible with earlier treeview controls such as 2010 and 2007?

    Cheers

    Brad

    Sunday, February 7, 2016 8:04 AM
  • The code I posted is as compatible with Excel-97 as with Excel 2016. The issue is whether or not MSComCtl.ocx exists on respective systems, then is it registered (and if Win-64 it must be registered in the correct place). If sharing files between users with different Win-32/64 references will break (can be reset). But if using Office 64 it won't work and there's no fix.

    In a new userform, toolbox, (rt-click) additional controls, "Microsoft Treeview Control 6.0 (SP6)". Thereafter select the treeview icon on the toolbox, normally adding the control will also add the reference (assuming the .ocx exists and is correctly registered).

    One more thing, Excel security settings must allow activeX controls.

    If using non-upgrade Win-10 it won't exist but can be installed, in theory though there are some reports of problems, see my reply here

    download MSComCtl.ocx

    Try the file you've got working on your 2016 with 2010 at work, it might simply work. 

    Moving forwards the non built-in aX controls will become increasingly problematic. If you get stuck there's a pure VBA treeview alternative, the free version is borderline OK with 2000 nodes (non-free for +20k nodes due soon)

    www.jkp-ads.com/articles/treeview.asp

    The code to populate your treeview would be slightly different.


    Sunday, February 7, 2016 10:41 AM
    Moderator