CODEWITHSUNDEEP
vbaexcelcopy
wongnog
wongnog

Reputation: 111

Copy selected rows twice

I've written a really rudimentary Excel macro to copy the selected row twice, then move the cursor down 3 rows so the process can be repeated again.

So if I have a file where the first 10 rows all need to be repeated twice, I run the macro 10 times.

This already saves me a bunch of keystrokes, but I'm sure it could be written better so I simply select the first 10 rows and then run the macro once.

Here's what I have so far:

Sub Copy_Twice()
' Copies current row twice

    ActiveCell.EntireRow.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    ActiveCell.EntireRow.Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    ActiveCell.Offset(rowOffset:=3).Select

End Sub

For every file I run this macro, it may not be the first 10 rows to be copied.

In fact an even better macro would be to copy every row twice if the cell in Column J is blank.

Update: File has a header row with values for columns A to X. The rows to be copied will be the first x # of rows after the header where column J is blank. So in one example, rows 2-11 need to be duplicated twice. But in another file, it may be rows 2-21.

Upvotes: 7

Views: 1862

Answers (4)

Vasily
Vasily

Reputation: 5782

try this:

Dim n&, x&
n = 0
x = Application.WorksheetFunction.CountIf(Range("J:J"), " ")
Range("A2").Select

While n <> x
    ActiveCell.EntireRow.Copy: ActiveCell.Offset(1, 0).EntireRow.Insert
    ActiveCell.EntireRow.Copy: ActiveCell.Offset(1, 0).EntireRow.Insert
    ActiveCell.Offset(3, 0).Select
    n = n + 1
Wend
Application.CutCopyMode = False
End Sub

Upvotes: 2

user4039065
user4039065

Reputation:

If column A can be relied upon to show the extents of the rows to be processed then finding the last populated row in column A and working toward row 2 should cover all of the rows to be processed.

Sub add_Duplicate_Blank_Js()
    Dim rw As Long

    With Worksheets("Sheet4")
        With .Cells(1, 1).CurrentRegion
            For rw = .Rows.Count To 2 Step -1
                If Not CBool(Len(.Cells(rw, "J"))) Then
                    With .Rows(rw).Cells
                        .Copy
                        .Resize(2, .Columns.Count).Insert Shift:=xlDown
                    End With
                End If
            Next rw
            Application.CutCopyMode = False
        End With
    End With
End Sub

With the titles across the first row and column A populated down to the full scope of the data, the above will walk backwards from the bottom to the top (recommended when inserting or deleting rows in a For Next Statement) of the Range.CurrentRegion property.

Upvotes: 0

Scott Holtzman
Scott Holtzman

Reputation: 27249

Here is some code that will allow the user to input the row count and test if column J is blank for each row:

Sub CopyRows()

Dim x As Integer
x = InputBox("How Many Rows to Copy?", 8)

Dim c As Range
Set c = Range("A2")

Dim y As Integer

For y = x to c.Row Step -1

    If IsEmpty(Cells(y, "J")) Then

        Cells(y,1).EntireRow.Copy: Cells(y,1).Resize(2,1).EntireRow.Insert Shift:=xlDown

    End If

Next

End Sub

Upvotes: 0

Siddharth Rout
Siddharth Rout

Reputation: 149287

Can I play too? :P

Here is the fastest way to do it. Let's say your data is from cell A1:A10. Simply run this code.

You don't have to use Copy/Paste at all.

What this code does is, inserts the blank rows and then simulates the Ctrl + G --> Special --> Blank Cells --> Fill blank cell with data from the above row using CTRL + ENTER.

For i = 10 To 2 Step -1
    Rows(i).Insert: Rows(i).Insert
Next i

'~~> After the blank rows are inserted your range will
'~~> expand up to row 30
Range("A1:A30").SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Range("A1:A30").Value = Range("A1:A30").Value '<~~ Convert formuals back to values

enter image description here

Upvotes: 3

Related Questions