I had some spare time, so I wrote a VBA Macro that can automate this. Since you have some knowledge of VBA, do go thru this code and understand where ever there exists little bit of hard coding. The macro does three things
- Transpose data from the input table into output table.
- Sort the Output table
- Merge the duplicate value cells in first column. However I suggest that you comment this part of the code, so that in future applying Pivot Table to output table shall be simplified if required.
In this example, Input table is in A1:C4 (A2:A4 being the Product Name cells). The output table starts at cell E1. Put this hard coding in VBA to match your table ranges. The sheet be named as 'Sheet1'. There is hard coding for Sheet name and Input Cell Range and Output Start Cell in the code. Please see all instances for the code to work correctly.
In your sheet press ALT + F11 to open VBA Editor and Insert a Module and paste the below code into it to create a Macro named Report.
Sub Report()
Dim noofrows As Integer
Dim startrow As Integer
Dim startcol As Integer
Dim repstartrow As Integer
Dim repstartcol As Integer
Dim bincode As String
Dim storagecode As String
'Hard Coding below
noofrows = Range("A2:A4").Rows.Count 'Specify the Input Data Range from a Column
startrow = Range("A2").Row
startcol = Range("A2").Column
repstartrow = Range("E1").Row 'Specify Output Data Table's First Cell here
repstartcol = Range("E1").Column
Cells(repstartrow, repstartcol).Value = "Products"
Cells(repstartrow, repstartcol).Font.Bold = True
Cells(repstartrow, repstartcol + 1).Value = "BinCode"
Cells(repstartrow, repstartcol + 1).Font.Bold = True
Cells(repstartrow, repstartcol + 2).Value = "StorageCode"
Cells(repstartrow, repstartcol + 2).Font.Bold = True
repstartrow = repstartrow + 1
For i = 1 To noofrows
Dim strTest As String
Dim strArray() As String
Dim intCount As Integer
strTest = Cells(startrow, startcol).Value
strArray = Split(strTest, ";")
bincode = Cells(startrow, startcol + 1).Value
storagecode = Cells(startrow, startcol + 2).Value
For intCount = LBound(strArray) To UBound(strArray)
Cells(repstartrow, repstartcol).Value = strArray(intCount)
Cells(repstartrow, repstartcol + 1).Value = bincode
Cells(repstartrow, repstartcol + 2).Value = storagecode
repstartrow = repstartrow + 1
Next intCount
startrow = startrow + 1
Next i
'Create All Borders to the table
'Hard Coding below
repstartrow1 = Range("E1").Row
repstartcol = Range("E1").Column
repstartrow = repstartrow - 1
Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
End With
'Auto Fit the Columns
Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Columns.AutoFit
'Sort the range on Product then Bincode & then StorageCode
Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Select
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol), Cells(repstartrow, repstartcol)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol + 1), Cells(repstartrow, repstartcol + 1)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol + 2), Cells(repstartrow, repstartcol + 2)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Optional - Merge Cells with repeating Values. Simply comment below code if not desired
repstartrow1 = Range("E1").Row + 1
repstartcol = Range("E1").Column
Application.DisplayAlerts = False
For i = repstartrow1 To repstartrow - 1
For j = i + 1 To repstartrow
If Cells(i, repstartcol).Value <> Cells(j, repstartcol).Value Then
Exit For
End If
Next
Range(Cells(i, repstartcol), Cells(j - 1, repstartcol)).Merge
Range(Cells(i, repstartcol), Cells(j - 1, repstartcol)).VerticalAlignment = xlTop
i = j - 1
Next
Range(Cells(repstartrow1 - 1, repstartcol), Cells(repstartrow1 - 1, repstartcol)).Select
Application.DisplayAlerts = True
End Sub
Save and exit back to Worksheet. Press ALT + F8 to access Macro Dialog Box and Run the Macro named Report to get the desired output table.
Note that you should not re-run this Macro again and again. It will work only once. However you can clear the previous output table and re-run this macro again to recreate the output table from scratch. Macro can be further enhanced to clear previous table as a first step before proceeding.