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

Table B (Expected outcome)

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

1. Identify the rows to be added
2. Insert them at once (to save memory instead of inserting one by one)
3. 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