VBA: Inserting variable number of rows + copy/paste

[Matthew_Schu]

Hello!

I am fairly new to VBA and I'm trying to insert a number of rows equal to the value of a number in a cell -1. Then I would like to copy and paste the information that was on the line prior to inserting the blank rows. So far, I've been able to insert a single blank row but nothing past that. The number I'm referencing is in column "U."
I would greatly appreciate any and all help. Thank you.

Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long

Col = "U"
StartRow = 1
BlankRows = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) > 1 Then
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With

Application.ScreenUpdating = True

End Sub

 

[ChrisFoster]

Sub InsertRows()

Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long

Col = "U"
StartRow = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) > 1 Then
            BlankRows = .Cells(R, Col) - 1 ' Calculate the number of rows to insert
            .Cells(R, Col).EntireRow.Copy ' Copy the contents of the current row
            .Cells(R, Col).Offset(1, 0).Resize(BlankRows, 1).EntireRow.Insert Shift:=xlDown ' Insert the blank rows
            .Cells(R, Col).Offset(1, 0).PasteSpecial xlPasteAll ' Paste the copied contents into the new rows
        End If
    Next R
End With

Application.ScreenUpdating = True

End Sub

 

[Matthew_Schu]

Sir,
Thank you for the quick response! I tried the code and it works for the first line but then I get the following Run-time error: "You can't paste this here because the Copy area and paste area aren't the same size. Select just one cell in the paste area or an area that's the same size, and try pasting again.

 

[Matthew_Schu]

Sub InsertRows()

Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long

Col = "U"
StartRow = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) > 1 Then
            BlankRows = .Cells(R, Col) - 1 ' Calculate the number of rows to insert
            .Cells(R, Col).EntireRow.Copy ' Copy the contents of the current row
            .Cells(R, Col).Offset(1, 0).Resize(BlankRows, 1).EntireRow.Insert Shift:=xlDown ' Insert the blank rows
            .Cells(R, Col).Offset(1, 0).PasteSpecial xlPasteAll ' Paste the copied contents into the new rows
        End If
    Next R
End With

Application.ScreenUpdating = True

End Sub

Sir,
Thank you for the quick response! I tried the code and it works for the first line but then I get the following Run-time error: "You can't paste this here because the Copy area and paste area aren't the same size. Select just one cell in the paste area or an area that's the same size, and try pasting again.

 

[ChrisFoster]

Hmm, try this and let me know.

Sub InsertRows()

Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long

Col = "U"
StartRow = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) > 1 Then
            BlankRows = .Cells(R, Col) - 1 'Get number of blank rows to insert
            .Rows(R + 1).Resize(BlankRows).Insert Shift:=xlDown 'Insert blank rows
            .Rows(R - BlankRows).Resize(BlankRows + 1).Copy 'Copy information from the row above
            .Rows(R + 1).Resize(BlankRows + 1).PasteSpecial xlPasteAll 'Paste information into the inserted rows
        End If
    Next R
End With

Application.ScreenUpdating = True

End Sub

 

[Matthew_Schu]

Hmm, try this and let me know.

Sub InsertRows()

Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long

Col = "U"
StartRow = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) > 1 Then
            BlankRows = .Cells(R, Col) - 1 'Get number of blank rows to insert
            .Rows(R + 1).Resize(BlankRows).Insert Shift:=xlDown 'Insert blank rows
            .Rows(R - BlankRows).Resize(BlankRows + 1).Copy 'Copy information from the row above
            .Rows(R + 1).Resize(BlankRows + 1).PasteSpecial xlPasteAll 'Paste information into the inserted rows
        End If
    Next R
End With

Application.ScreenUpdating = True

End Sub

Sir,
This one doesn't give me the Run-time error but it is copying and pasting the variable number of rows instead of the one row that many times. For example, if the number in Column U is 7, then it is copying all 6 rows and pasting them in rather than copying the row the 7 was on and pasting that in 6 more times.

 

[ChrisFoster]

This is stressful

Try:

Sub InsertRows()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim i As Long

Col = "U"
StartRow = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) > 1 Then
            BlankRows = .Cells(R, Col) - 1
            For i = 1 To BlankRows
                .Cells(R, Col).EntireRow.Insert Shift:=xlDown
            Next i
            .Cells(R - 1, 1).Copy
            .Range(Cells(R, 1), Cells(R + BlankRows, 1)).PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End If
    Next R
End With

Application.ScreenUpdating = True

End Sub

 

[Matthew_Schu]

This is stressful

Try:

Sub InsertRows()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim i As Long

Col = "U"
StartRow = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) > 1 Then
            BlankRows = .Cells(R, Col) - 1
            For i = 1 To BlankRows
                .Cells(R, Col).EntireRow.Insert Shift:=xlDown
            Next i
            .Cells(R - 1, 1).Copy
            .Range(Cells(R, 1), Cells(R + BlankRows, 1)).PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End If
    Next R
End With

Application.ScreenUpdating = True

End Sub

It is stressful and I cannot thank you enough for your help. Soooo this one works with inserting the correct number of rows but it is only copying and pasting the information on Column A instead of copying and pasting the entire row. To clarify, it's almost perfect but the only information being pasted in is what's on Column A with the rest of the row being blank.

 

[ChrisFoster]

This should work, hopefully.

Sub InsertRows()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim i As Long

Col = "U"
StartRow = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) > 1 Then
            BlankRows = .Cells(R, Col) - 1
            For i = 1 To BlankRows
                .Cells(R, Col).EntireRow.Insert Shift:=xlDown
            Next i
            .Cells(R - 1, 1).EntireRow.Copy
            .Range(Cells(R, 1), Cells(R + BlankRows, 1)).EntireRow.PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End If
    Next R
End With

Application.ScreenUpdating = True

End Sub

 

[Matthew_Schu]

This should work, hopefully.

Sub InsertRows()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim i As Long

Col = "U"
StartRow = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) > 1 Then
            BlankRows = .Cells(R, Col) - 1
            For i = 1 To BlankRows
                .Cells(R, Col).EntireRow.Insert Shift:=xlDown
            Next i
            .Cells(R - 1, 1).EntireRow.Copy
            .Range(Cells(R, 1), Cells(R + BlankRows, 1)).EntireRow.PasteSpecial xlPasteAll
            Application.CutCopyMode = False
        End If
    Next R
End With

Application.ScreenUpdating = True

End Sub

I have tried messing with it so I didn't have to bother you again. Everything works perfectly except it's the copying the line above instead. It inserts the correct number of rows but then it grabs the next row up instead of the row with the numbered value it created the rows for.