CODEWITHSUNDEEP
vbaexcelloopswhile-loop
Mwspencer
Mwspencer

Reputation: 1183

Create Rows, then Copy and Paste Original Row into New Rows

I have a row with a cell that specifies the number of rows to insert underneath. That part of my code worked fine. I then want to take the contents of the original row and paste into the newly created rows, then delete information from a specific cell in those rows. That is where I am having the issues. Here is my code:

Set ws = ActiveSheet

Dim rw, num As Long

rw = 5

While ws.Cells(rw, 16).Value <> ""
    num = ws.Cells(rw, 16).Value

    If num = 0 Then
        rw = rw + 1
    Else

        Range(Cells(rw + 1, 16), Cells(rw + num, 16)).EntireRow.Insert shift:=xlDown
        Rows(rw).Select
        Selection.Copy
        Range(Rows(rw + 1), Rows(rw + num)).Paste
        Range(Cells(rw + 1, 9), Cells(rw + num, 9)).ClearContents
        rw = rw + num + 1
    End If
Wend

End Sub

I do not understand why I cannot paste the original row contents into my newly created rows The original row is copied and is on my ms clipboard but does not paste. I have tried using Range().Paste, Rows().Paste, Cells().Paste and combinations of the three and so far nothing has worked. Any help is greatly appreciated, thanks.

Upvotes: 0

Views: 93

Answers (2)

Part_Time_Nerd
Part_Time_Nerd

Reputation: 1014

I would use what @pascalbaro wrote but also get rid of the select statements. In addition you may want to limit the screen updating if this is your only sub routine. If not just add them into the one that calls them.

Application.ScreenUpdating = False
Set ws = ActiveSheet
Dim rw, num As Long
rw = 5

While ws.Cells(rw, 16).Value <> ""
    num = ws.Cells(rw, 16).Value

    If num = 0 Then
        rw = rw + 1
    Else

        Range(Cells(rw + 1, 16), Cells(rw + num, 16)).EntireRow.Insert shift:=xlDown

        'remove the selection statements
        Rows(rw).Copy

        Range(Rows(rw + 1), Rows(rw + num)).PasteSpecial Paste:=xlPasteAll, _
            Operation:=xlNone, SkipBlanks:=True, Transpose:=False

        Range(Cells(rw + 1, 9), Cells(rw + num, 9)).ClearContents

        rw = rw + num + 1

    Application.CutCopyMode = False

    End If
Wend

Application.ScreenUpdating = True

Upvotes: 0

pascal b
pascal b

Reputation: 371

You can try


    Range(Rows(rw + 1), Rows(rw + num)).PasteSpecial xlPasteValues
    Application.CutCopyMode = False

or


    Range(Rows(rw + 1), Rows(rw + num)).PasteSpecial Paste:=xlPasteAll, _
            Operation:=xlNone, SkipBlanks:=True, Transpose:=False
        Application.CutCopyMode = False

Upvotes: 0

Related Questions