A bit of background info and how is the database designed...
Please notice you don't really have to rebuild the tables in SQL but I shared an SQL Fiddle just in case and screenshots1 of what the database looks like. I thought it was going to be easier to explain the story of what I am doing + you can always quickly build your own if you wanted to.
So the tables look like:
PART table basically stores all Parts. The
PARTARC is a table that stores relationships.
In this scenario a more logical explanation of what
PARTARC actually represents would be:
PART1is a complete KIT and includes:
PART2(a LEFT-HAND model)
PART5(a RIGHT-HAND model)
PART2is a left-hand model made up of 2 components
B(Buy) type component)
B(Buy) type component)
PART3is just a sticker/label. The
Mtype means it's made at the factory.
PART4is a low-level component of
PART2really is but the RIGHT-HAND model, made up of
B(Buy) type component)
B(Buy) type component)
PART6is a low-level component of
The point here is that
PART1 is the top-level assembly part and it's made up of other components like for example
PART5 which are of type
M which means they can also be made and sold separately as top-level assemblies. The
B means that the part is not sold separately and can't be a top level assembly - this is why you shouldn't (will not) find the
B type parts in column A on spreadsheet.
Hope this is now all clear.
To build an object oriented data structure off of the tables and populate the spreadsheet in a very specific way.
The goal is to print out all Parent parts followed by their Children relationship to spreadsheet in a very specific format shown below. (click the image for full resolution):
Note: the prices may seem illogical as PART1 is made up of other more expensive parts but it's final price is quite low. Please ignore that fact, it's completely irrelevant in the scenario. The
Price column's purpose is only to have an extra property on the
I have created my own COM library to hide the connection string details form the end user. Basically, it comes down to attaching references to my .tlb, creating an instance of the COM class and returning an active
ADODB.Connection to by calling
VBA Project structure:
Module1 - Engine
Option Explicit Private cn As ADODB.Connection ' global due to being passed around Sub Main() Dim cnWrapper As ConnectionExt ' COM Set cnWrapper = New ConnectionExt ' COM Set cn = cnWrapper.GetConnection ' Gets an active ADODB.Connection ' if sucessfully connected then If (cn.State And adStateOpen) = adStateOpen Then Dim c As Parts Set c = New Parts BuildTheCollection c If Not IsEmpty([A1]) Then Cells.Delete ' clear spreadsheet PrintTheCollection c, 1 ' being called resursively AddAndFormatHeaders ' can't be called from PrintTheCollection due to recursitivity End If If Not (cn Is Nothing) Then If (cn.State And adStateOpen) = adStateOpen Then cn.Close Set cn = Nothing End If Set cnWrapper = Nothing End If End Sub Private Sub BuildTheCollection(c As Parts) Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset On Error GoTo AllPartsHandler ' grab all the M type parts rs.Open Queries.AllParts, cn, adOpenStatic, adLockOptimistic ' iterate the recordset and build the OO structure While Not rs.EOF ' returns and adds to Parts collection a new Part instance based on the PartId c.Add CreatePart(rs(0)) rs.MoveNext Wend AllPartsHandler: Debug.Print IIf(Len(Err.Description) > 0, "All Parts Query Handler says: " & Err.Description, vbNullString) If Not (rs Is Nothing) Then If (rs.State And adStateOpen) = adStateOpen Then rs.Close Set rs = Nothing End If End If Exit Sub End Sub Function CreatePart(Id As Long, Optional theParent As Part) As Part Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset On Error GoTo SinglePartHandler rs.Open Queries.FromPartId(Id), cn, adOpenStatic, adLockOptimistic Dim p As Part Set p = New Part If Not theParent Is Nothing Then Set p.Parent = theParent Else Set p.Parent = p p.IsRoot = True End If p.Id = rs(0) p.T = rs(1) p.Name = rs(2) p.Price = rs(3) Set p.Children = GetChildren(p) If Not (rs Is Nothing) Then If (rs.State And adStateOpen) = adStateOpen Then rs.Close Set rs = Nothing End If End If Set CreatePart = p Exit Function SinglePartHandler: Debug.Print IIf(Len(Err.Description) > 0, "Single Part Query Handler says: " & Err.Description, vbNullString) If Not (rs Is Nothing) Then If (rs.State And adStateOpen) = adStateOpen Then rs.Close Set rs = Nothing End If End If End Function Function GetChildren(ByRef p As Part) As Parts Dim rs As ADODB.Recordset Set rs = New ADODB.Recordset On Error GoTo ChildrenHandler rs.Open Queries.Sons(p.Id), cn, adOpenStatic, adLockOptimistic Dim c As Parts Set c = New Parts On Error GoTo ChildrenHandler ' if has children , check and then add them If rs.RecordCount > 0 Then While Not rs.EOF Dim newPart As Part Set newPart = CreatePart(rs(0), p) c.Add newPart rs.MoveNext Wend End If If Not (rs Is Nothing) Then If (rs.State And adStateOpen) = adStateOpen Then rs.Close Set rs = Nothing End If End If Set GetChildren = c Exit Function ChildrenHandler: Debug.Print IIf(Len(Err.Description) > 0, "Children Query Handler says: " & Err.Description, vbNullString) If Not (rs Is Nothing) Then If (rs.State And adStateOpen) = adStateOpen Then rs.Close Set rs = Nothing End If End If End Function
Module2 - Printer
Option Explicit Sub PrintTheCollection(c As Parts, Optional depth As Long) Application.ScreenUpdating = False Dim p As Part For Each p In c If p.IsRoot Then Dim row As Long row = Range("A" & Rows.Count).End(xlUp).row + 1 Range("A" & row) = p.Name Range("B" & row) = p.T Range("C" & row) = p.Price If p.Children.Count > 0 Then PrintTheCollection p.Children End If Else row = Range("A" & Rows.Count).End(xlUp).row Dim column As Long column = Cells(row, Columns.Count).End(xlToLeft).column + 1 Cells(row, column) = p.Name Cells(row, column + 1) = p.T Cells(row, column + 2) = p.Price Cells(row, column + 3) = p.Parent.Name If p.Children.Count > 0 Then PrintTheCollection p.Children End If End If Next Application.ScreenUpdating = True End Sub Sub AddAndFormatHeaders(Optional trigger As Boolean) Application.ScreenUpdating = False 'add headers [A1] = "PART NAME" [b1] = "TYPE" [c1] = "PRICE" [d1] = [A1] [e1] = [b1] [f1] = [c1] [g1] = "PARENT" Dim i As Long, j As Long ' the cells are deleted and there will be no user input on the sheet ' so usedRange.Columns.Count will always be fine here For i = 8 To ActiveSheet.UsedRange.Columns.Count Step 4 For j = 0 To 3 Cells(1, i + j) = Cells(1, j + 4) Next Next With ActiveWindow .SplitColumn = 0 .SplitRow = 1 End With ActiveWindow.FreezePanes = True Columns.AutoFit Application.ScreenUpdating = True End Sub
Public Id As Long Public IsRoot As Boolean Public Name As String Public T As String ' * 1 <- yeah, I wish there was a Char type Public Price As Double Public Parent As Part Public Children As Parts Private Sub Class_Initialize() Set Children = New Parts End Sub Private Sub Class_Terminate() Set Children = Nothing End Sub
Parts Collection Class (any TextEditor -> save to
.cls -> import file into VBA Project
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "Parts" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Private c As Collection Private Sub Class_Initialize() Set c = New Collection End Sub Private Sub Class_Terminate() Set c = Nothing End Sub Public Sub Add(ByVal ItemToAdd As Part c.Add ItemToAdd End Sub Public Property Get Item(index As Long) As Part Attribute Item.VB_UserMemId = 0 Set Item = c.Item(index) End Property Public Property Get NewEnum() As IUnknown Attribute NewEnum.VB_UserMemId = -4 Set NewEnum = c.[_NewEnum] End Property Public Property Get Count() As Long Count = c.Count End Property
Queries static class -> Txt Editor -> save .cls -> import file VBA
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "Queries" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Option Explicit Public Function AllParts() As String AllParts = "SELECT PART.PartId as 'PART ID' , " & _ " PART.Type as 'TYPE' , " & _ " PART.Name as 'PART NAME', " & _ " PART.Price as 'PRICE' " & _ "FROM " & _ " PART " & _ "WHERE " & _ " PART.Type = 'M' " End Function Public Function FromPartId(Id As Long) As String FromPartId = "SELECT PART.PartId as 'PART ID' , " & _ " PART.Type as 'TYPE' , " & _ " PART.Name as 'PART NAME', " & _ " PART.Price as 'PRICE' " & _ "FROM " & _ " PART " & _ "WHERE " & _ " PART.PartId = " & Id & " " End Function Public Function Sons(Id As Long) Sons = "SELECT PARTARC.Son " & _ "FROM " & _ " PARTARC " & _ " left join PART on PART.PartId = PARTARC.Son " & _ "WHERE " & _ " PARTARC.Part = " & Id End Function
CreatePart()function in Module1 a sign of bad encapsulation? Shouldn't it be a part of
Partclass? I was debating that for a long time but ended up doing it the way shown above. If I wanted to make this a member of
Partclass I would have to make
Partstatic or have a spare, free-floating instance of
Parthanging around - and I didn't want to do that. If you can think of a better approach I would love to hear about it.
Error handling... I not sure I am doing it correctly. I have been encountering tons of errors before I tied everything up and have had at least 10 different ways to handle different errors. Once I started getting rid of some of the errors and I knew the exact reason an error occurred I assumed (rather safely) that some of them will not happen again I removed extra handlers.
Tested the code in a real life situation with 2K parts in the PART table and over 30K in the PARTARC. In my case the code built up the collection in about the same time it was printing it to the spreadsheet (30 seconds & 30 seconds) - therefore if there is anything I have missed or could be improved to speed things up a bit I would really appreciate your advices.
Speed, efficiency, general approach etc.. Any tips, improvements are very welcome.
One thing though - please pretend my variable named
c has a proper, more suitable name. That
Collection is like
i in a for loop for me ;)