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
CodePudding user response:
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
CodePudding user response:
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