The story...
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:
The 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)PART3(a LABEL/STICKER)
PART2is a left-hand model made up of 2 componentsPART4(aB(Buy) type component)PART6(aB(Buy) type component)
PART3is just a sticker/label. TheMtype means it's made at the factory.PART4is a low-level component ofBtype.PART5is whatPART2really is but the RIGHT-HAND model, made up ofPART4(aB(Buy) type component)PART6(aB(Buy) type component)
PART6is a low-level component ofBtype.
The point here is that PART1 is the top-level assembly part and it's made up of other components like for example PART2 or 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.
The goal...
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 PART class.
Current solution
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 cnWrapper.GetConnection.
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
Part class
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
Concerns:
Is the
CreatePart()function in Module1 a sign of bad encapsulation? Shouldn't it be a part ofPartclass? 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 ofPartclass I would have to makePartstatic or have a spare, free-floating instance ofParthanging 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 c for Collection is like i in a for loop for me ;)
