Transform table structure - excel

Question

Hello is any sensible algorithm for transforming data table (Table A to Table B) ?
I trying to moving cells , but have no idea how to calculate a place where I should place additional row after my key field Name.
Table A origin
Name
Salary
Bonus
Amount
John S.
5000
Bonus A
50
John S.
Bonus B
100
Alex G.
7000
Bonus C
150
Alex G.
Bonus D
300
Table B (Expected outcome)
Name
Salary
Bonus
Amount
John S.
5000
John S.
Bonus A
50
John S.
Bonus B
100
Alex G.
7000
Alex G.
Bonus C
150
Alex G.
Bonus D
300
Sub TransformTable()
' Setting variables
Dim Name As String
Dim BaseSalary As String
Dim BonusName As String
Dim BonusAmount As Double
'Setting worksheet object
Dim SheetData As Worksheet
Set SheetData = Sheets("SheetData")
'counter for main loop
Dim x As Long
'Setting main object array
Dim MyArray As Variant
Dim Item As Integer
Item = 1
'reading values from table
MyArray = Worksheets("SheetData").ListObjects("Table1").DataBodyRange.Value
'counting last row value
'main loop
For x = LBound(MyArray) To UBound(MyArray)
'condition check how many costcenter ids with fixed value
lstRowSrs = SheetData.Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("SheetData").Cells(Item + 1, 13).Value = MyArray(x, 1)
Worksheets("SheetData").Cells(Item + 1, 14).Value = MyArray(x, 2)
If MyArray(x, 3) <> "" Then
' Cells(x, lstRowSrs).EntireRow.Insert
Worksheets("SheetData").Cells(Item + 2, 15).Value = MyArray(x, 3)
Worksheets("SheetData").Cells(Item + 2, 16).Value = MyArray(x, 4)
Item = Item + 1
Else
Worksheets("SheetData").Cells(Item + 1, 15).Value = MyArray(x, 3)
Worksheets("SheetData").Cells(Item + 1, 16).Value = MyArray(x, 4)
Item = Item + 1
End If
Next x
End Sub

Answer 1

You can obtain your desired output using Power Query, available in Windows Excel 2010+ and Office 365 Excel
Select some cell in your original table
Data => Get&Transform => From Table/Range
When the PQ UI opens, navigate to Home => Advanced Editor
Make note of the Table Name in Line 2 of the code.
Replace the existing code with the M-Code below
Change the table name in line 2 of the pasted code to your "real" table name
Examine any comments, and also the Applied Steps window, to better understand the algorithm and steps
The basic algorithm:
Unpivot the Salary and Amount columns which puts them all into a single column
the Bonus column will have some duplicates -- remove them if the Attribute column contains "Salary"
Remove the contents of the Salary column; rename and reorder the columns
M Code
let
//change table name in next line to actual name in your workbook
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
//set the data types
#"Changed Type" = Table.TransformColumnTypes(Source,{
{"Name", type text}, {"Salary", Int64.Type}, {"Bonus", type text}, {"Amount", Int64.Type}}),
//Unpivot the columns other than Name and Bonus
#"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Name", "Bonus"}, "Attribute", "Value"),
//blank the "bonus" if attribute=salary
#"Replace Bonus with null" = Table.ReplaceValue(#"Unpivoted Other Columns",
each [Bonus],
each if [Attribute]="Salary" then null else [Bonus],
Replacer.ReplaceValue,{"Bonus"}),
//set columns in correct order
#"Reordered Columns" = Table.ReorderColumns(#"Replace Bonus with null",{"Name", "Attribute", "Bonus", "Value"}),
//rename "Attribute"=>"Salary" and blank the contents
Rename = Table.RenameColumns(#"Reordered Columns",{{"Attribute","Salary"},{"Value","Amount"}}),
blankIt = Table.ReplaceValue(Rename, each [Salary],null, Replacer.ReplaceValue,{"Salary"})
in
blankIt

Answer 2

Here's another way. It has the same results as #Sgdva but uses some slightly different techniques. Not better, just something to consider.
Sub TransformTable()
Dim vaValues As Variant
Dim i As Long
Dim aOutput() As Variant
Dim lCnt As Long
'put all the values in a 2-d array
vaValues = Sheet1.ListObjects(1).DataBodyRange
'make your output array - double the rows of the input
'it will be too many rows, but you won't run out of room
ReDim aOutput(1 To UBound(vaValues, 1) * 2, 1 To 4)
'Loop through the 2-d array
For i = LBound(vaValues, 1) To UBound(vaValues, 1)
If Len(vaValues(i, 2)) > 0 Then 'a salary exists
'add a row to the output array
lCnt = lCnt + 1
aOutput(lCnt, 1) = vaValues(i, 1)
aOutput(lCnt, 4) = vaValues(i, 2)
End If
If Len(vaValues(i, 4)) > 0 Then 'a bonus exists
'add a row to the output array
lCnt = lCnt + 1
aOutput(lCnt, 1) = vaValues(i, 1)
aOutput(lCnt, 3) = vaValues(i, 3)
aOutput(lCnt, 4) = vaValues(i, 4)
End If
Next i
'write out the output array in one shot
Sheet1.Range("G1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub

Answer 3

Solution
I changed the logic that you posted as follows
Identify the rows to be added
Insert them at once (to save memory instead of inserting one by one)
Append the data needed by looping again in the rows
For demonstration purposes, I limited the logic to the active sheet and with the data sample shown.
Demo
Code
Sub Exec_DivideSalary()
Dim CounterRow As Long
Dim RangeRowsToAdd As Range
For CounterRow = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(CounterRow, 2).Value <> "" Then ' 1. If Cells(CounterRow, 2).Value <> ""
If RangeRowsToAdd Is Nothing Then ' 2. If RangeRowsToAdd Is Nothing
Set RangeRowsToAdd = Rows(CounterRow + 1)
Else ' 2. If RangeRowsToAdd Is Nothing
Set RangeRowsToAdd = Union(RangeRowsToAdd, Rows(CounterRow + 1))
End If ' 2. If RangeRowsToAdd Is Nothing
End If ' 1. If Cells(CounterRow, 2).Value <> ""
Next CounterRow
RangeRowsToAdd.Insert Shift:=xlDown
For CounterRow = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(CounterRow, 2).Value <> "" Then ' 3. If Cells(CounterRow, 2).Value <> ""
Cells(CounterRow + 1, 1).Value = Cells(CounterRow, 1).Value: Cells(CounterRow + 1, 3).Value = Cells(CounterRow, 3).Value: Cells(CounterRow + 1, 4).Value = Cells(CounterRow, 4).Value
Cells(CounterRow, 4).Value = Cells(CounterRow, 2).Value
Cells(CounterRow, 2).Value = "": Cells(CounterRow, 3).Value = ""
End If ' 3. If Cells(CounterRow, 2).Value <> ""
Next CounterRow
End Sub