Unpivot Setup

Code to collect parameters and initiate the un-pivot operation. To use the code, copy from this text file.

In each MSExcel tab containing a Structured Table to be un-pivoted:

Private Sub unPivot()
    'Copyright (c) 2017 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice.

    Dim tblSourceUnpivotName As String, tabTargetUnpivotName As String
    Dim colElementItemName As String, tblTargetUnpivotName As String
    Dim colElementValueName As String, MessageBarColRptName As String
    Dim thisWorkbook As Workbook
    Dim thisWorksheet As Worksheet
    Dim thisWorksheetName As String
    Dim rngCellInTblTarget As Range
    
    'Set up workbook and worksheet references
    Set thisWorkbook = module1.myworkbook
    'Make reference to thisWorksheet by looping through worksheets until we find tab named 
        'AllocationTable
    For Each thisWorksheet In thisWorkbook.Sheets 'Find worksheet "Allocation Table" for source data
        If thisWorksheet.Name = "AllocationTable" Then Exit For
    Next thisWorksheet
    
    'Catch unpivot variables specified on source worksheet
    tblSourceUnpivotName = thisWorksheet.Cells.Range("tblSourceUnpivotName")
    tabTargetUnpivotName = thisWorksheet.Cells.Range("tabTargetUnpivotName")
    tblTargetUnpivotName = thisWorksheet.Cells.Range("tblTargetUnpivotName")
    colElementItemName = thisWorksheet.Cells.Range("colElementItemName")
    colElementValueName = thisWorksheet.Cells.Range("colElementValueName")
    MessageBarColRptName = thisWorksheet.Cells.Range("MessageBarColRpt")
    
    'Call the unpivot / Do the work ! passing in the params picked up just above
    Module1.unPivot tblSourceUnpivotName:=tblSourceUnpivotName, _
                    tabTargetUnpivotName:=tabTargetUnpivotName, _
                    tblTargetUnpivotName:=tblTargetUnpivotName, _
                    thisWorksheet:=thisWorksheet, _
                    colElementItemName:=colElementItemName, _
                    colElementValueName:=colElementValueName, _
                    MessageBarColRpt:=MessageBarColRptName
    
    'Make a named range that can be used to export the UnPivot table to a Database such as MSAccess 
        'or SQLserver
    'First identify a cell in tblTargetUnpivot
    If exists(tblTargetUnpivotName, thisWorkbook.Worksheets(tabTargetUnpivotName).ListObjects) Then
        Set rngCellInTblTarget = thisWorkbook.Worksheets(tabTargetUnpivotName). _
            ListObjects(tblTargetUnpivotName).Range.Cells(2, 1)
    
    End If
    'Then call TableUpdate to make and name the Range of the table so that it will be visible to 
    'MSAccess and SQLserver.
    Module1.TableUpdate Target:=rngCellInTblTarget
    
    'The Unpivot commmand button is an OLE form object which may wander on the page; after each use 
        'set up its size and position.
    thisWorksheet.OLEObjects("CommandButton1").Width = thisWorksheet.Range(Cells(2, 4), _
        Cells(2, 5)).Width '111
    thisWorksheet.OLEObjects("CommandButton1").Height = thisWorksheet.Range(Cells(2, 4), _
        Cells(3, 5)).Height'28
    thisWorksheet.OLEObjects("CommandButton1").Top = thisWorksheet.Cells(2, 4).Top   '16
    thisWorksheet.OLEObjects("CommandButton1").Left = thisWorksheet.Cells(2, 4).Left '302
    
    'Mark tblTargetUnpivot as Dirty so pivot reports will update
    Worksheet_Change Target:=rngCellInTblTarget 
            'Mark tblTargetUnpivot as Dirty so pivot reports will update
   
End Sub

Unpivot Execution

Code that executes the un-pivot operation. To use the code, copy from this text file.

In MSExcel, Module1:

Public Sub unPivot(ByVal tblSourceUnpivotName As String, tabTargetUnpivotName As String, _
        tblTargetUnpivotName As String, colElementItemName As String, colElementValueName As String, _
        thisWorksheet As Worksheet, MessageBarColRpt As String)
    'Copyright (c) 2017 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice.

    
    'Workbook
    Dim thisWorkbook As Workbook
    Dim tabTargetUnpivot As Worksheet
    Dim saveCalc As XlCalculation
    Dim saveUpdate As Boolean
    
    'Source Table
    Dim tblSourceUnpivot As ListObject
    Dim collSourceHeadings As New Collection
    Dim collSourceUnpivot As New Collection
    Dim unpivotRow As ListRow
    Dim collSrc_R_fields As New Collection
    Dim collSrc_C_fields As New Collection
    Dim collSrcAllocationRows As New Collection
    
    'Target Table
    Dim tblTargetUnpivot As ListObject
    Dim collTargetHeadings As New Collection
    Dim collTargetHeadingNames As New Collection
    Dim thisCell As Range
    Dim C_Row As ListRow
    Dim colTargetTableElement As Integer, colTargetTableElementValue As Integer
    
    'Non-persistent Work Variables
    Dim thisHeaderCell As Range
    Dim thisRow As ListRow
    Dim colIndex As Integer
    Dim objTest As Object
    Dim index As Integer, headerIndex As Integer, rowIndex As Integer, colIndexR As Integer, _
        colSrcHeaderName As Integer, keyValRtgt As Integer
    Dim keyval As Variant, rowval As Variant, keyval2 As Variant, rowval2 As Variant, _
        keyValR As Variant, rowValR As Variant
    Dim srcHeaderName As String
    Dim nametest
    
    'Create collSrcAllocationRows collection to list tblSourceUnpivot rows 
            'with field [Control] = #Allocation
    'Create collSrc-R-fields to map all tblSourceUnpivot headers, 
            'with #R in Unpivot row[Control] field, to column number
    'Create collSrc-C-fields to map all tblSourceUnpivot headers, 
            'with #C in Unpivot row[Control] field, to column number
    'Create collTargetHeadings to map all tblTargetUnpivot headers, to column number
    
    'Delete tblTargetUnpivot rows with field [Control] = #Allocation    
                'Clean out old target table #allocation rows (leaves behing non-#Allocation rows tho 
                'for expense etc)
    
    'For each thisSrcRow in lstSrcAllocationRows
    '   Create new thisDestRow
    '   For each thisSrc-C-field in collSrc-C-fields    
                        'Scan across source C-fields for current source #allocation row
    '       For each thisSrc-R-field in collSrc-R-fields    
                        'Scan across source R-fields in current source #allocation row
    '           Copy value from thisSrcRow[thisSrc-R-field] into 
                        'thisDestRow[collTargetHeadings[thisSrc-R-Field]]    
                        'Copy R-Fields from Src Row to new Dest Row
    '
    '       Next thisSrc-R-Field
    '
    '       thisDestRow[collTargetHeadings[colElementItemName]] = thisSrc-C-field    
                        'Then put the header name for the C-field from current source row, 
                        'into the new Dest Row
    '       'And then the value of thisSrcRow[collSrc-C-Fields[thisSrc-C-field]]  
                        'into thisDestRow[collTargetHeadings[colElementValueName]]  
                        'And the source value corresponding to the current C-field into the target 
                        'C-field
    '
    '   'Next thisSrc-C-field
    '
    'Next thisSrcRow
    
    'Set up Environment
    saveUpdate = Application.ScreenUpdating
    Application.ScreenUpdating = False
    Set thisWorkbook = module1.myworkbook
    saveCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ""
    
    Set thisWorkbook = thisWorksheet.Parent
    If exists(tblSourceUnpivotName, thisWorksheet.ListObjects) Then
        'SOURCE TABLE
        '   tblSourceUnpivot is the source table
        '   collSourceHeadings contains mapping of source table column title to column number
        '   collSourceUnpivot contains mapping of source table column title to unpivot instruction 
            '#R or #C. 
                'Null instruction results in ignoring the column in unpivot operation.
        Application.StatusBar = "Source Table Setup"
        Set tblSourceUnpivot = thisWorksheet.ListObjects(tblSourceUnpivotName)
        If Not tblSourceUnpivot.HeaderRowRange Is Nothing Then
            'Set up collSourceHeadings mapping all source header names to column numbers
            For colIndex = 1 To tblSourceUnpivot.HeaderRowRange.Count
            keyval = tblSourceUnpivot.HeaderRowRange(colIndex)
                collSourceHeadings.Add Item:=colIndex, Key:=keyval
            Next colIndex
                        
            For index = 1 To tblSourceUnpivot.ListRows.Count
                Set thisRow = tblSourceUnpivot.ListRows(index)
                
                'For Each thisRow In tblSourceUnpivot.ListRows
                'Find the Unpivot row (#R and #C instructions) and build collSrc_R_fields and 
                        'collSrc_C_fields listing header names for R, and header names for C
                keyval = Int(collSourceHeadings("Control"))
                rowval = thisRow.Range.Cells(1, keyval).Value2
                
                If rowval = "#Allocation" Then 'Found Unpivot instruction row
                    collSrcAllocationRows.Add Item:=index, Key:=CStr(index)   
                            'Build list of #Allocation rows in tblSourceUnpivot
                    
                End If
                
                keyval = Int(collSourceHeadings("Control"))
                rowval = thisRow.Range.Cells(1, keyval).Value2
                If rowval = "#R" Then 'Found Unpivot instruction row
                    'Set unpivotRow = thisRow    
                            'unpivotRow is the unpivot instruction row in tblSourceUnpivot.ListRows
                    For headerIndex = 1 To tblSourceUnpivot.HeaderRowRange.Count
                        Set thisHeaderCell = tblSourceUnpivot.HeaderRowRange(headerIndex)
                        rowval = thisRow.Range.Cells(1, headerIndex).Value2
                        keyval = thisHeaderCell.Value2
                        
                        If rowval = "#R" Then
                            collSrc_R_fields.Add Item:=headerIndex, Key:=keyval
                            
                        ElseIf rowval = "#C" Then
                            collSrc_C_fields.Add Item:=headerIndex, Key:=keyval
                            
                        End If
                        
                    Next headerIndex
                    
                End If
            
            Next index
        
        End If
        
        'TARGET WORKSHEET
        Application.StatusBar = "Target Worksheet Setup"
        If exists(tabTargetUnpivotName, thisWorkbook.Worksheets) Then
            Set tabTargetUnpivot = thisWorkbook.Worksheets(tabTargetUnpivotName)
        
        Else
            createWorksheet thisName:=tabTargetUnpivotName
            Set tabTargetUnpivot = thisWorkbook.Worksheets(tabTargetUnpivotName)
            thisWorksheet.Activate
        
        End If
        
        'TARGET TABLE
       Application.StatusBar = "Target Table Setup"
        If exists(tblTargetUnpivotName, tabTargetUnpivot.ListObjects) Then
            Set tblTargetUnpivot = tabTargetUnpivot.ListObjects(tblTargetUnpivotName)
        
        Else
            Set tblTargetUnpivot = TableHandler.insertTable( _
                    tabTargetUnpivot, tblTargetUnpivotName, "tableVertical")
            
        End If
        
        If Not tblTargetUnpivot.HeaderRowRange Is Nothing Then
            'Set up collTargetHeadings mapping all Target header names to column numbers
            For colIndex = 1 To tblTargetUnpivot.HeaderRowRange.Count
                Set thisHeaderCell = tblTargetUnpivot.HeaderRowRange(colIndex)
                keyval = thisHeaderCell.Value2
                collTargetHeadings.Add Item:=colIndex, Key:=keyval   'colIndex
                collTargetHeadingNames.Add Item:=keyval
                
            Next colIndex
            
        End If
        
    End If
    
    'Delete tblTargetUnpivot rows with field [Control] = #Allocation    
        'Clean out old target table #allocation rows (leaves behind non-#Allocation rows tho for 
        'expense etc)
    For index = tblTargetUnpivot.ListRows.Count To 1 Step -1
        Application.StatusBar = "Delete Target Table #Allocation rows: " _
                    & Format(tblTargetUnpivot.ListRows.Count, "0")
        DoEvents
        
        Set thisRow = tblTargetUnpivot.ListRows(index)
        keyval = collTargetHeadings("Control")
        rowval = thisRow.Range.Cells(1, keyval).Value2
        If rowval = "#Allocation" Then thisRow.Delete
        
    Next index
    
    'Now the Un-Pivot!
    
    Application.StatusBar = "Un-Pivot"
    colTargetTableElement = 0
    colTargetTableElementValue = 0
    colTargetTableElement = collTargetHeadings(colElementItemName)
    colTargetTableElementValue = collTargetHeadings(colElementValueName)
    If (colTargetTableElement > 0) And (colTargetTableElementValue > 0) Then  
                'Make sure the target element and target element value fields do exist in the 
                'target table
        For rowIndex = 1 To collSrcAllocationRows.Count
            keyval = collSrcAllocationRows(rowIndex)    
                'Get each #Allocation row and set up thisRow object reference to the real row
            Set thisRow = tblSourceUnpivot.ListRows(keyval)
            
            keyval = collSourceHeadings(MessageBarColRpt)
            rowval = thisRow.Range.Cells(1, keyval).Value2
            Application.StatusBar = "Un-Pivot: " & CStr(collSrcAllocationRows(rowIndex)) & " of " & _
                Format(tblSourceUnpivot.ListRows.Count, "0") & ": " & rowval    
                        'wasnt Format(collSrcAllocationRows.Count, "0")
            DoEvents
            
            keyval = collSrc_R_fields("Control")
            rowval = thisRow.Range.Cells(1, keyval).Value2
            If rowval = "#Allocation" Then
                
                For colIndex = 1 To collSrc_C_fields.Count
                    keyval = collSrc_C_fields(colIndex)
                    rowval = thisRow.Range.Cells(1, keyval).Value2      
                            'Check if the C_Value >0.  look up the C_Val value
                    If rowval > 0 Then                                  
                            'Only process a new C-record if there's a C_Val item to add ie qty >0
                        Set C_Row = tblTargetUnpivot.ListRows.Add       
                            'Add new target row if c-element value > 0
                        C_Row.Range.Cells(1, colTargetTableElement) = tblSourceUnpivot. _
                            HeaderRowRange(keyval) 
                            'Fill in the C elementname in the target element column.
                        C_Row.Range.Cells(1, colTargetTableElementValue) = rowval 
                            'Fill in the C value in the target element value column.
                        
                        'Scan the source R columns
                        '   and copy to the target R columns if the target R column exists and 
                            'if r value >0
                        For colIndexR = 1 To collSrc_R_fields.Count
                            keyValR = collSrc_R_fields(colIndexR)                       
                                    'Get src column and src value
                            rowValR = thisRow.Range.Cells(1, keyValR).Value2
                            srcHeaderName = tblSourceUnpivot.HeaderRowRange(keyValR).Value2    
                                'Get col name
                            
                            If nameExists(srcHeaderName, collTargetHeadingNames) Then     
                                    'Check if that heading exists in target and ignore if it doesn't
                                keyValRtgt = collTargetHeadings(srcHeaderName)          
                                    'get target column
                                
                                C_Row.Range.Cells(1, keyValRtgt) = rowValR              
                                    'Copy the source row R-Value field to the corresponding 
                                    'target row R-Value field
                                
                            End If
                            
                        Next colIndexR
                    
                    End If
                    
                Next colIndex
                
            End If
            
        Next rowIndex
    
    End If
    
    'Restore Environment
    Application.Calculate
    Application.Calculation = saveCalc
    Application.StatusBar = ""
    Application.ScreenUpdating = saveUpdate
         
End Sub

Private Function nameExists(ByVal thisName As String, ByRef thisCollection As Variant) As Boolean
    Dim thisItem As Variant
    Dim n As Integer
    Dim thisItemName As String
    
    nameExists = False
    For Each thisItem In thisCollection
        thisItemName = CStr(thisItem)
        
        If thisItemName = thisName Then nameExists = True Else nameExists = False
        If nameExists Then Exit Function
        
    Next thisItem
    
End Function

SQL Pseudocode for BOM Explosion

SQL Pseudocode to explode a BOM within a database environment, driven by an Allocation table. To use the code, copy from this text file.

An Access query:

/* Copyright (c) 2017 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice. */
/*
tblTop /* structure: Use and Allocation of Items */
	TopItemLineNum
	TopItemName
	TopItemRev
	TopItemQty
	TopItemCommon /* (several fields re Use and Allocation) */
	TopItemRevKey /* (= [ItemName] & ":" & [ItemRev] ) */
	TopItemIDKey /* (= TopItemName ) */

tblBOM /* structure: (Structured BOM tree of makeup of Items) */
	BOMLineNum
	ItemName
	ItemRev
	ItemRevKey /* (= [ItemName] & ":" & [ItemRev] ) */
	SubName
	SubRev
	SubRevKey /* (= [SubName] & ":" & [ItemRev] ) */
	SubQty

tblDates /* structure: Dates for build and assembly of items */
	datesLineNum
	ItemName
	ItemRev
	ItemRevKey /* (= [ItemName] & ":" & [ItemRev] ) */
	TaskName
	TaskDate
*/

/* Query qL0 */
SELECT
	tblTop.TopItemLineNum AS TopItemLineNum,
	tblTop.TopItemName AS TopItemName,
	tblTop.TopItemRev AS TopItemRev,
	tblTop.TopItemQty AS TopItemQty,
	tblTop.TopItemRevKey AS TopItemRevKey,
	tblTop.TopItemIDKey AS TopItemIDKey,
	BOM0.SubName AS ItemName,
	BOM0.SubRev AS SubRev,
	BOM0.SubQty AS ItemRevQty,
	BOM0.SubRevKey AS ItemRevKey,
	'L0' AS Level
FROM tblTop
LEFT OUTER JOIN tblBOM AS BOM0
	ON tblTop.TopItemRevKey = BOM0.ItemRevKey;


/* Query qL1*/
SELECT
	qL0.TopItemLineNum AS TopItemLineNum,
	qL0.TopItemName AS TopItemName,
	qL0.TopItemRev AS TopItemRev,
	qL0.TopItemQty AS TopItemQty,
	qL0.TopItemRevKey AS TopItemRevKey,
	qL0.TopItemIDKey AS TopItemIDKey,
	BOM1.SubName AS ItemName,
	BOM1.SubRev AS SubRev,
	BOM1.SubQty * qL0.ItemRevQty AS ItemRevQty,
	BOM1.SubRevKey AS ItemRevKey,
	'L1' AS Level
FROM qL0
LEFT OUTER JOIN tblBOM AS BOM1
	ON qL0.ItemRevKey = BOM1.ItemRevKey;


/* Query qL2* (and repeat pattern incrementing qL1, qL2, BOM2... up to qLfinal) */
SELECT
	qL1.TopItemLineNum AS TopItemLineNum,
	qL1.TopItemName AS TopItemName,
	qL1.TopItemRev AS TopItemRev,
	qL1.TopItemQty AS TopItemQty,
	qL1.TopItemRevKey AS TopItemRevKey,
	qL1.TopItemIDKey AS TopItemIDKey,
	BOM2.SubName AS ItemName,
	BOM2.SubRev AS SubRev,
	BOM2.SubQty * qL1.ItemRevQty AS ItemRevQty,
	BOM2.SubRevKey AS ItemRevKey,
	'L2' AS Level
FROM qL1
LEFT OUTER JOIN tblBOM AS BOM2
	ON qL1.ItemRevKey = BOM2.ItemRevKey;


/* Query qDetailL1 (example of one such query per qLn: n=0 to final) */
SELECT
	qL1.*, tblTop.TopItemCommon, tblBOM.*, tblItemRevData.*, tblItemData.*, tblDates.*
FROM qL1
LEFT OUTER JOIN tblTop AS Top
	ON qL1.TopItemLineNum=Top.TopItemLineNum
LEFT OUTER JOIN tblItemRevData
	ON qL1.ItemRevKey=tblItemRevData.ItemRevKey
LEFT OUTER JOIN tblItemData
	ON qL1.ItemIDKey=tblItemData.ItemIDKey
LEFT OUTER JOIN tblDates
	ON qL1.ItemRevKey=tblDates.ItemRevKey;


/* Final Union Query */
SELECT qDetailL0.* FROM qDetailL0
UNION ALL
SELECT qDetailL1.* FROM qDetailL1
UNION ALL
...
UNION ALL
SELECT qDetailLfinal.* FROM qDetailLfinal;