3
\$\begingroup\$
  • I MIGHT REWRITE THIS QUESTION IN A CLEARER WAY WITH SOME SAMPLES TOO AND POST IT AS ANOTHER SOON, AS NOW MY EXPLAINATION HERE IS QUITE HARD TO UNDERSTAND & MIGHT BE PHRASED WRONG.

I do have background knowledge in programming, but this is my first time using VBA so any advice is appreciated.

This code is the final part of the program where it essentially output a report matching demands against supplies based on Sale Order>Need By Date>item hierarchy.

First, the code takes the data in the "tree" sheet which consist of the item/order no. and its respective levels - (1,2,3,...)/hierarchy and puts it into an array. Then, it iterates through to find the relevant data matched based on the order number in another matched data (that matched demands to its corresponding supplies) created in the initial part of the program and puts it in order based on the item hierarchy and output all relevant data on the final report.

The program is taking about 20s to sort/match & output the final data into a spreadsheet, but I need it to be faster then that. Currently the whole process takes about 40s to generate the report for 10k lines of test data, but i have to generate the report for 1 million lines in about a minute.

Sub SortHierarchyList()

With Excel.Application
 .ScreenUpdating = False
        .Calculation = Excel.xlManual
        .EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
End With

StartTime = Timer
  
    Sheets("Order").Rows(2 & ":" & Rows.Count).Delete
    
    'last row for hierarchy tree sheet
     'max column for hierarchy tree sheet
    Dim treelastrw As Long, treemaxcol As Long
    treelastrw = Sheets("tree").Cells(Rows.Count, "A").End(xlUp).row:  treemaxcol = Sheets("tree").Range("A1").SpecialCells(xlCellTypeLastCell).Column
   
    Dim ColumnLetter As String
    ColumnLetter = Split(Cells(1, treemaxcol).Address, "$")(1): treeArray = Sheets("tree").Range("A1:" & ColumnLetter & treelastrw): mArray = Sheets("Matcher").Range("A1:X" & treelastrw): outputArray = Sheets("Order").Range("A1:Z" & treelastrw)
    
    'Create Dictionary, adding ranking sheet to the dictionary
     'Create Dictionary, adding ranking sheet to the dictionary
    Dim RankDict As Object, SortDict As Object
    Set RankDict = RankingDict: Set SortDict = SortingDict

    'actual sorting
    For treerow = LBound(treeArray, 1) + 1 To UBound(treeArray, 1)
        'from second column onwards to max column (max level for bom tree) (1st column is just used for ".")
        For i = 3 To treemaxcol
            'for each row in hierarchy tree, find the first instance of a value (from second column onwards)
            If RankDict.Exists(treeArray(treerow, i)) Then
                'sales order will change once the array iterates down the tree to the next sales order
                If i = 3 Then
                    highestlevel = treeArray(treerow, i)
                    For j = treerow - 1 To 1 Step -1
                        If treeArray(j, i - 1) <> vbNullString Then
                            currentSalesOrder = treeArray(j, i - 1)
                            Exit For
                        End If
                    Next j
                End If
                 'find the corresponding demand number by looking one column to the left and up onwards from indexed row to first row
                'the first instance of a value would be the corresponding demand number
                outputArray(treerow, 25) = highestlevel: outputArray(treerow, 26) = currentSalesOrder:  childSupply = treeArray(treerow, i)
               
                For j = treerow - 1 To 1 Step -1
                    If treeArray(j, i - 1) <> vbNullString Then
                        parentDemand = treeArray(j, i - 1)
                        Exit For
                    End If
                Next j
                'find in matched list array where demand and supply corresponds to childsupply and parent demand
                For matchlistrow = LBound(mArray, 1) + 1 To UBound(mArray, 1)
                    'check if the item has already been used and listed in the sorted table
                    If SortDict(matchlistrow) = 0 Then
                        If mArray(matchlistrow, 5) = parentDemand Then
                            If mArray(matchlistrow, 16) = childSupply Then
                                'lay out the row information
                                For col = 1 To 24
                                    outputArray(treerow, col) = mArray(matchlistrow, col)
                                Next col
                                'swap back to blank field if no suppply available
                                If outputArray(treerow, 16) = "No Supply" Then
                                    outputArray(treerow, 16) = vbNullString
                                End If
                                'update whether the matched row has been used in the sorted sheet already
                                SortDict(matchlistrow) = 1
                                GoTo nextloop
                            End If
                        End If
                    End If
                Next matchlistrow
            End If
        Next i
nextloop:
    Next treerow
    
    'adds in missing rows
    For i = 2 To UBound(outputArray, 1)
        If outputArray(i, 11) = vbNullString Then
            For j = 3 To treemaxcol
                If RankDict.Exists(treeArray(i, j)) Then
                    For y = 1 To UBound(mArray)
                        If SortDict(y) = 0 Then
                            If mArray(y, 16) = treeArray(i, j) Then
                                For col = 1 To 24
                                    outputArray(i, col) = mArray(y, col)
                                Next col
                                SortDict(y) = 1
                                GoTo nextEmpty
                            End If
                        End If
                    Next y
                End If
            Next j
        End If
nextEmpty:
    Next i
    
    'output
    Sheets("Order").Range("A1:Z" & treelastrw) = outputArray
    'resize columns to fit accordingly
      
    SecondsElapsed = Round(Timer - StartTime, 1)
    Debug.Print "Sorter Output Time: " & SecondsElapsed & "s"
    
    
    With Excel.Application
   ActiveSheet.DisplayPageBreaks = True
  .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
        .EnableEvents = True
  End With
   
End Sub
Function RankingDict() As Dictionary
    'last row for ranking sheet
    Dim endrow As Long
    endrow = Sheets("rank").Cells(Rows.Count, "A").End(xlUp).row
    Dim dict As New Dictionary
    For i = 1 To endrow
        Key = Sheets("rank").Cells(i, 1).Value2: Item = Sheets("rank").Cells(i, 2).Value2
        dict.Add Key, Item
    Next i
    Set RankingDict = dict
End Function
'to check whether the row has been used in the sorted output or not
'helps to avoid duplicates
Function SortingDict() As Dictionary
    'last row for ranking sheet
    Dim endrow As Long
    endrow = Sheets("Matcher").Cells(Rows.Count, "A").End(xlUp).row
    Dim dict As New Dictionary
    For i = 1 To endrow
        Key = i: Item = 0
        dict.Add Key, Item
    Next i
    Set SortingDict = dict
End Function

This is the code that assigns the materials its assembly level and matched them according to the demand/supply order number. This part also took quite awhile to process. about 15s or so. I don't know if it's the sorting part that takes up the most time or what.

Sub bomTree()


With Excel.Application
   .ScreenUpdating = False
        .Calculation = Excel.xlManual
        .EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
End With


    Dim hSh As Worksheet
    Dim iRow As Integer, oRow As Integer, hRow As Integer
    Dim iCol As Integer, oCol As Integer, hCol As Integer
    Dim iParent As String, iChild As String, oNode As String
    Dim bParentFound As Boolean, bChildFound As Boolean
    Dim hLevel As Integer, cHierarchy As Range
    Dim cChildRow As Long, cParentRow As Long
    
    
    StartTime2 = Timer
    
    'Assign Cell Values
    Set hSh = Sheets("tree")
    Sheets("rank").Cells.Clear
    
    'Find Ranking Number for Each Node
    'Loop Thru Each Cell
    lastrow = Sheets("sbs").Cells(Rows.Count, "A").End(xlUp).row
    iSh = Sheets("sbs").Range("A1:B" & lastrow)
    
    secondlastrow = Sheets("Matcher").Cells(Rows.Count, "A").End(xlUp).row
    oSh = Sheets("rank").Range("A1:B" & secondlastrow)
    
    For iRow = LBound(iSh, 1) To UBound(iSh, 1)
        iParent = iSh(iRow, 1): iChild = iSh(iRow, 2)
        
        oRow = 1
        bParentFound = False: bChildFound = False
        Do While oSh(oRow, 1) <> vbNullString
            oNode = oSh(oRow, 1)
            If oNode = iParent Then
                bParentFound = True: cParentRow = oRow
            Else
                If oNode = iChild Then
                    bChildFound = True: cChildRow = oRow
                End If
            End If
            
            If bParentFound And bChildFound Then
                Exit Do
            End If
            oRow = oRow + 1
        Loop
        
        If bParentFound = False Then
            While oSh(oRow, 1) <> vbNullString
                oRow = oRow + 1
            Wend
            oSh(oRow, 1) = iParent
            oSh(oRow, 2) = 0
            cParentRow = oRow
        End If
        If bChildFound = False Then
            While oSh(oRow, 1) <> vbNullString
                oRow = oRow + 1
            Wend
            oSh(oRow, 1) = iChild
            cChildRow = oRow
        End If
        
        oSh(cChildRow, 2) = "=1+$B$" & cParentRow
    Next iRow
    
    Sheets("rank").Range("A1:B" & secondlastrow) = oSh
    
    'Sort Nodes Based on its Ranking
  
    
    
    Set oSh = Sheets("rank")
    oSh.Sort.SortFields.Clear
    oSh.Sort.SortFields.Add Key:=Range("B1:B" & oRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With oSh.Sort
        .SetRange Range("A1:B" & oRow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
     Dim RankDict As Object
    Set RankDict = RankingDict
    
   SecondsElapsed = Round(Timer - StartTime2, 1)
    Debug.Print "rank output time: " & SecondsElapsed & "s"
    
   
    'Build Hierarchy Chart Table or Organization Chart
    'Place Each Node in its Hierarchy Level
    StartTime = Timer
    


    hSh.Cells.Clear
    hRow = 1
    secondlastrow = oSh.Cells(Rows.Count, "A").End(xlUp).row:
    sheetTwoArray = oSh.Range("A1:B" & secondlastrow)
    
    For oRow = LBound(sheetTwoArray, 1) To UBound(sheetTwoArray, 1)
        oNode = sheetTwoArray(oRow, 1): hLevel = sheetTwoArray(oRow, 2) + 2
        Set cHierarchy = Find_First_In_Range(oNode, hSh.Cells)
        If cHierarchy Is Nothing Then
            hSh.Cells(hRow, hLevel) = oSh.Cells(oRow, 1)
        Else
            hRow = cHierarchy.row
        End If
        
        For iRow = LBound(iSh, 1) To UBound(iSh, 1)
            iParent = iSh(iRow, 1): iChild = iSh(iRow, 2)
            
            If iParent = oNode Then
                hRow = hRow + 1
                hSh.Rows(hRow & ":" & hRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                hSh.Cells(hRow, hLevel + 1) = iChild: hSh.Cells(hRow, 1) = "."
            End If
        Next iRow
    Next oRow
    
    

     
      SecondsElapsed = Round(Timer - StartTime, 1)
    Debug.Print "tree output time: " & SecondsElapsed & "s"


With Excel.Application
     .ScreenUpdating = True
        .Calculation = Excel.xlAutomatic
        .EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End With
   
End Sub
Function Find_First_In_Range(FindString As String, iRng As Range) As Range
    Dim rng As Range
    If FindString <> vbNullString Then
        With iRng
            Set rng = .Find(What:=FindString, _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
        End With
    End If
    Set Find_First_In_Range = rng
End Function
\$\endgroup\$
6
  • 1
    \$\begingroup\$ Using formulas and the built-in sorting functions of Excel would be faster than rolling your own code. Can you explain why you need to do this? \$\endgroup\$
    – HackSlash
    Mar 15, 2022 at 15:35
  • \$\begingroup\$ Basically i have to automate a shortages report from a BOM list. firstly i have matched the demand materials to our supply. After that i need to sort the matched data according to their assembly level. For example, from lvl 0-3. 0 being the items needed first and 3 being last. So, i have already coded out what level each materials is and now have to sort thru the matched data according to the levels, which will ultimately be the shortage report. \$\endgroup\$
    – hyerii
    Mar 16, 2022 at 8:11
  • \$\begingroup\$ now currently the whole process takes about 40s to generate the report for 10k lines of test data. But i have to generate the report for 1million lines in about a minute. \$\endgroup\$
    – hyerii
    Mar 16, 2022 at 8:14
  • 2
    \$\begingroup\$ @hyerii This is a bit hard for me to visualize. Could you share some sample data of before and after running this code? \$\endgroup\$ Mar 17, 2022 at 12:27
  • \$\begingroup\$ Please don't modify the code in your question after receiving answers. \$\endgroup\$
    – Mast
    Mar 23, 2022 at 7:56

1 Answer 1

2
\$\begingroup\$

Use of Dictionaries slows down the process and needs more RAM then a built in Arrays in VBA they are much faster than external use of Dictionaries.

Use of native data structures increases speed, if that's what you are after.

Edit:

I agree with @Greedo(in comments), but there is a catch. Since it is needed to copy the dictionary to other sheet/sheets it is this operation that is realy slow and takes the majoraty of time to be executed. In my personal experiance it was faster to do the operations with dictionary and before putting it out to sheets place it in array

Edit2:

This is the code that assigns the materials its assembly level and matched them according to the demand/supply order number. This part also took quite awhile to process. about 15s or so. I don't know if it's the sorting part that takes up the most time or what.

If you use sorting for Dictionaries then you have misunderstood use of Dictionaries

Suggestion:

  1. Try reading all data before performing calculations Jumping from workbook to other workbook and sheet to sheet takes time.
  2. if you use delete in VBA you could just skip/ignore the lines instead
  3. Do not loop through Ranges use Arrays to perform search/find it is 50x faster
\$\endgroup\$
2
  • 3
    \$\begingroup\$ Actually this kind of comment is perfectly fine as an answer - you make a suggestion about a change to the code and explain the justification behind it. Perhaps a bit more info on how exactly you would make that change world be useful, since of course dictionaries and arrays have different properties (e.g. an array had no methods like .Exists(key), how would you replace them in OP's code?) \$\endgroup\$
    – Greedo
    Mar 15, 2022 at 10:51
  • 3
    \$\begingroup\$ As it stands I'm not sure I am convinced by your answer: a Dictionary does need more memory but not by much, and the OP does not claim to be short on memory. "native data structures" are not necessarily faster just because they come by default with VBA, making calls to the Dictionary is as fast as making calls to a VBA built-in Collection. In terms of the data structure, an Array makes it extremely fast to look up an item by index, but it is slow to locate an item since you have to loop until you find it, for a Dictionary it is a single operation if you have the key. How can Arrays help here? \$\endgroup\$
    – Greedo
    Mar 15, 2022 at 11:02

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.