Excel VBA - add rows in dependence of a value in a cell-CodePudding

I have a table with information in column A and an appropriate value in column B. I want to write a macro that inserts a new row for each "Person" in dependence of the value in column B and copies the original information into that row, which for example means that in the end there are 5 rows with "Person A", 2 rows for "Person B" etc.

original table:

result:

My first approach looks like that. It doesn't work.

Dim i, j, k As Integer

For i = Range("A" & Range("A:A").Rows.Count).End(xlUp).Row To 1 Step -1
 
        For j = 1 To Range("B" & i)
            
            Rows(i).Select
            Selection.Insert Shift:=xlDown
            
            k = k   j
                            
            Range(Cells(k, 1), Cells(k, 2)).Copy Destination:=Range("A" & i)
            
        Next j
        
Next i

CodePudding user response：

This would work for you, changing the number of inserts based on value in column B:

Option Explicit

Sub test()
    With Sheets(1)
        Dim lastRow As Long:  lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim i As Long
        For i = lastRow To 1 Step -1
            If IsNumeric(.Cells(i, 2).Value) = True Then
                Dim numberOfInserts As Long
                numberOfInserts = .Cells(i, 2).Value - 1
                If numberOfInserts > 0 Then
                    Dim insertCount As Long
                    For insertCount = 1 To numberOfInserts
                        .Rows(i).Copy
                        .Rows(i).Insert
                    Next insertCount
                End If
            End If
        Next i
    End With
End Sub

First we check that you're dealing with numbers. Second you have a single line already, so number -1, then that this number is >0. Lastly, you insert via a loop which does the counting for you.

Test data:

Output after running:

CodePudding user response：

Your index calculation is messed up. Use the debugger, step thru the code (F8) and notice what happens:

a) Your Select/Insert-construct creates a new row above the row you want to copy, not below.
b) Your calculation of index k fails: You are not initializing k, so it starts with value 0. Than you add j (1..3) to k, resulting in values 1, 3, 6, and copy data from that line.

I would suggest you take a different approach: Copy the original data into an array and then loop over that array. This avoids multiple Select, Copy and Insert statements (that are slow) and allow to copy the data from top to bottom.

Sub copy()
    Dim rowCount As Long
    Dim data As Variant
    
    With ActiveSheet    ' Replace with the sheet you want to work with
        
        ' Copy the current table into array
        rowCount = .Cells(.Rows.Count, 1).End(xlUp).row
        data = .Range(.Cells(1, 1), .Cells(rowCount, 2))
        
        Dim oldRow As Long, newRow As Long
        newRow = 1
        ' Loop over old data
        For oldRow = 1 To rowCount
            Dim repeatCount As Long
            repeatCount = Val(data(oldRow, 2)) ' We want to have so many occurrences of the row
            if repeatCount <= 0 Then repeatCount=1
            Dim col As Long
            ' Create "repeatCount" rows of data (copy column by column)
            For col = 1 To 2
                .Cells(newRow, col).Resize(repeatCount, 1) = data(oldRow, col)
            Next col
            newRow = newRow   repeatCount
        Next
        
    End With
End Sub