Create new line then copy and paste row

0
votes

Im trying to create an excel macro to select a range of cells then insert new row every other row then copy and paste each row.

For example.

apples
oranges
mangos

My desired goal is

apples
apples
oranges
oranges
mangos
mangos

I have thousands of rows and a macro would be nice.

This Inserts a new row,every other row.


Sub InsertNewRows()
    Dim rng As Range
    Dim CountRow As Integer
    Dim i As Integer
    Set rng = Selection
    CountRow = rng.EntireRow.Count
    
    For i = 1 To CountRow
        ActiveCell.Offset(1, 0).EntireRow.Insert
        ActiveCell.Offset(2, 0).Select
    Next i
End Sub

How can I duplicate the lines in the range too?

2
excelvba
Just wondering, Is it critical inserting new rows? I mean, wouldn't work a code that copies twice keeping same order?. So If range A2:A4 = Apples / Oranges / Mangos, the code would copy twice and would Be A2:A7 = Apples / Apples / Oranges / Oranges / Mangos / Mangos. Copying is faster than inserting new rows if you have thousands of rows. – Foxfire And Burns And Burns

2 Answers

1
votes

Not inserting rows, this code copies and pastes each value twice. Inserting rows is really time consuming.

Here's a screenshot of before/after running code:

enter image description here

Sub test()
Dim MyData As Variant
Dim LR As Long
Dim i As Long
Dim Initial_Row As Long

LR = Range("A" & Rows.Count).End(xlUp).Row 'last non blank cell in column A

MyData = Range("A1:A" & LR).Value 'all data into array

Initial_Row = 1 'initial row where data starts pasting

For i = 1 To UBound(MyData) Step 1
    Range("A" & Initial_Row & ":A" & Initial_Row + 1).Value = MyData(i, 1)
    Initial_Row = Initial_Row + 2
Next i

Erase MyData 'delete data
End Sub
0
votes

I recommend to read the values into an array and duplicate them into another array and finally write that array to the cells. This is much faster than duplicating cells.

Option Explicit

Public Sub DuplicateSelectedRows()
    Dim SelRng As Range
    Set SelRng = Selection
    
    ' read values into array
    Dim SelectedValues As Variant
    SelectedValues = SelRng.Value
    
    ' create output array of double the size
    Dim DuplicatedValues As Variant
    ReDim DuplicatedValues(1 To UBound(SelectedValues, 1) * 2, 1 To UBound(SelectedValues, 2))
    
    ' duplicate values
    Dim iRow As Long
    For iRow = 1 To UBound(SelectedValues, 1)
        DuplicatedValues(iRow * 2 - 1, 1) = SelectedValues(iRow, 1)
        DuplicatedValues(iRow * 2, 1) = SelectedValues(iRow, 1)
    Next iRow
    
    ' output values
    SelRng.Cells(1, 1).Resize(RowSize:=UBound(DuplicatedValues)).Value = DuplicatedValues
End Sub