Adding Rows & Copying Data in Row Above

[Wilconcl51]

I'm using Excel On Line
My spreadsheet has 2 columns. Colum A = Name ; Column B= Number
I'm using code to add rows below based on the Number in Column B. eg B = 2 then 2 rows inserted; B=3 then 3 rows inserted.
Code

Sub InsertRows() Dim i As Long, lRow As Long With ActiveSheet lRow = .Cells(.Rows.Count, 2).End(xlUp).Row For i = lRow To 1 Step -1 If IsNumeric(Cells(i,2)) Then .Rows(i + 1).Resize(Cells(i, 11)).Insert End If Next End With End Sub How can I change code to insert Rows and Copy Name in Row above to inserted Rows Many thanks

 

[kevin9999]

No worries - try this instead:

Option Explicit
Sub InsertRows_V4()
    Dim s As String, i As Long, j As Long, k As Long, n As Long, a, b
    a = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
    n = WorksheetFunction.Sum(Columns("B:B"))
    
    If n > 0 Then
        j = 1
        ReDim b(1 To UBound(a, 1) + n, 1 To 2)
        For i = 1 To UBound(a, 1)
            s = a(i, 1)
            b(j, 1) = s: b(j, 2) = a(i, 2)
            If IsNumeric(a(i, 2)) And a(i, 2) > 1 Then
                k = a(i, 2)
                For n = 1 To k
                    b(j, 1) = a(i, 1): j = j + 1
                Next n
            Else
                j = j + 1
            End If
        Next i
        Range("A1").Resize(UBound(b, 1), 2) = b
    End If
End Sub

 

[Wilconcl51]

No worries - try this instead:

Option Explicit
Sub InsertRows_V4()
    Dim s As String, i As Long, j As Long, k As Long, n As Long, a, b
    a = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
    n = WorksheetFunction.Sum(Columns("B:B"))
   
    If n > 0 Then
        j = 1
        ReDim b(1 To UBound(a, 1) + n, 1 To 2)
        For i = 1 To UBound(a, 1)
            s = a(i, 1)
            b(j, 1) = s: b(j, 2) = a(i, 2)
            If IsNumeric(a(i, 2)) And a(i, 2) > 1 Then
                k = a(i, 2)
                For n = 1 To k
                    b(j, 1) = a(i, 1): j = j + 1
                Next n
            Else
                j = j + 1
            End If
        Next i
        Range("A1").Resize(UBound(b, 1), 2) = b
    End If
End Sub

Perfect.
Sorry for stuffing you around
Garry