- 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
