Note that there is code below for an Excel VBA Module "Module1", and also for an Excel VBA Module "TableHandler". --------------------------- Add a Module1 to Excel containing the following code: Option Explicit 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_R_names 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 nameExists(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 collSrc_R_names.Add Item:=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 'Create tblTargetUnpivot Set tblTargetUnpivot = TableHandler.insertTable(tabTargetUnpivot, tblTargetUnpivotName, "tableVertical") For headerIndex = 1 To collSrc_R_names.Count If headerIndex <= tblTargetUnpivot.HeaderRowRange.Count Then tblTargetUnpivot.HeaderRowRange(headerIndex) = collSrc_R_names(headerIndex) If headerIndex > tblTargetUnpivot.HeaderRowRange.Count Then tblTargetUnpivot.ListColumns.Add.Name = collSrc_R_names(headerIndex) Next headerIndex 'Name the columns: all #R from tblAllocationTable, plus one for ElementItemName and one for ElementItemValue. tblTargetUnpivot.ListColumns.Add.Name = colElementItemName tblTargetUnpivot.ListColumns.Add.Name = colElementValueName 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 behing 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(rowIndex) & " of " & Format(collSrcAllocationRows.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 column 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 Public 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 Private Function createWorksheet(ByVal thisName As String) As Worksheet Set createWorksheet = Worksheets.Add(, , 1, xlWorksheet) createWorksheet.Name = thisName End Function Public Function exists(ByVal thisName As String, ByVal thisCollection As Variant) As Boolean Dim thisItem As Variant exists = False For Each thisItem In thisCollection If thisItem.Name = thisName Then exists = True Exit Function End If Next thisItem End Function --------------------------- Add Excel Module "TableHandler", containing the following code: Option Explicit 'Table setup and I/O support. Public tableCount As Integer Public tableSpacer As Integer Public Function insertTable(ByVal thisWorksheet As Worksheet, ByVal tableName As String, ByVal tableDirection As String) As ListObject 'Adds a new Excel table to the specified worksheet Dim originRow As Integer, originCol As Integer, tableCols As Integer Dim tblOffset As Integer, tblSpace As Integer Dim rangeString As String, tableRangeStr As String Dim insertedTable As ListObject tableCols = 2 tblOffset = 1 tblSpace = 2 tableCount = tableCount + 1 tableName = tableName '& "_" & Format(tableCount, "0") tableRangeStr = tableName & "[#All]" Select Case tableDirection Case "tableVertical" originRow = findLastActiveRow(thisWorksheet) + tblSpace + tableSpacer originCol = 2 Case "tableHorizontal" originCol = findLastActiveColumn(thisWorksheet) + tblSpace originRow = tblSpace + tableSpacer End Select 'rangeString = "$" & colLetter(originCol) & "$" & Format(originRow, "0") & ":$" & colLetter(originCol + tableCols - 1) & "$" & Format(originRow, "0") rangeString = thisWorksheet.Name & "!" & "$" & colLetter(originCol) & "$" & Format(originRow, "0") & ":$" & colLetter(originCol + tableCols - 1) & "$" & Format(originRow, "0") thisWorksheet.ListObjects.Add(xlSrcRange, Range(rangeString), , xlYes).Name = tableName Set insertTable = thisWorksheet.ListObjects(tableName) End Function Public Function colLetter(ByVal colNum As Integer) As String 'Translates column number to column letter. If colNum > 26 Then ' 1st character: Subtract 1 to map the characters to 0-25, ' but you don't have to remap back to 1-26 ' after the 'Int' operation since columns ' 1-26 have no prefix letter ' 2nd character: Subtract 1 to map the characters to 0-25, ' but then must remap back to 1-26 after ' the 'Mod' operation by adding 1 back in ' (included in the '65') colLetter = Chr(Int((colNum - 1) / 26) + 64) & Chr(((colNum - 1) Mod 26) + 65) Else ' Columns A-Z colLetter = Chr(colNum + 64) End If End Function Private Function findLastActiveRow(ByVal thisWorksheet As Worksheet) 'Looks through all tables on the sheet, finds last active row. Dim thisListObject As ListObject Dim maxTableRowFound As Integer, lastTableRow As Integer, rowcount As Integer maxTableRowFound = 0 For Each thisListObject In thisWorksheet.ListObjects If Not thisListObject.DataBodyRange Is Nothing Then lastTableRow = thisListObject.DataBodyRange.Rows(thisListObject.DataBodyRange.Rows.Count).Row maxTableRowFound = WorksheetFunction.Max(maxTableRowFound, lastTableRow) maxTableRowFound = maxTableRowFound - 1 'Compensate for insert-row in this case... ElseIf Not thisListObject.HeaderRowRange Is Nothing Then lastTableRow = thisListObject.HeaderRowRange.Row maxTableRowFound = WorksheetFunction.Max(maxTableRowFound, lastTableRow) End If Next thisListObject findLastActiveRow = maxTableRowFound End Function Private Function findLastActiveColumn(ByVal thisWorksheet As Worksheet) 'Looks through all tables on the sheet, finds last active column. Dim thisListObject As ListObject Dim maxTableColFound As Integer, lastTableCol As Integer, colcount As Integer maxTableColFound = 0 For Each thisListObject In thisWorksheet.ListObjects If Not thisListObject.DataBodyRange Is Nothing Then lastTableCol = thisListObject.DataBodyRange.Columns(thisListObject.DataBodyRange.Columns.Count).Column maxTableColFound = WorksheetFunction.Max(maxTableColFound, lastTableCol) ElseIf Not thisListObject.HeaderRowRange Is Nothing Then lastTableCol = thisListObject.HeaderRowRange.Columns(thisListObject.HeaderRowRange.Columns.Count).Column maxTableColFound = WorksheetFunction.Max(maxTableColFound, lastTableCol) End If Next thisListObject findLastActiveColumn = maxTableColFound End Function