How to automatically make copies of rows in Excel?

Question

I have an excel file which looks like this:
row1_cell1 row1_cell2 row1_cell3
row2_cell1 row2_cell2 row2_cell3
row3_cell1 row3_cell2 row3_cell3

How can i make three (or any number of) copies of each row that i have in the sheet, which i would like to be added after the row being copied? So, in the end i would like to have this kind of a result:
row1_cell1 row1_cell2 row1_cell3
row1_cell1 row1_cell2 row1_cell3
row1_cell1 row1_cell2 row1_cell3
row2_cell1 row2_cell2 row2_cell3
row2_cell1 row2_cell2 row2_cell3
row2_cell1 row2_cell2 row2_cell3
row3_cell1 row3_cell2 row3_cell3
row3_cell1 row3_cell2 row3_cell3
row3_cell1 row3_cell2 row3_cell3

Answer 1

This is how I would do that for all rows on the sheet:

Option Explicit

Sub MultiplyRows()
Dim RwsCnt As Long, LR As Long, InsRw As Long

RwsCnt = Application.InputBox("How many copies of each row should be inserted?", "Insert Count", 2, Type:=1)    
If RwsCnt = 0 Then Exit Sub
LR = Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
For InsRw = LR To 1 Step -1
    Rows(InsRw).Copy
    Rows(InsRw + 1).Resize(RwsCnt).Insert xlShiftDown
Next InsRw
Application.ScreenUpdating = True

End Sub

Answer 2

There isn't a direct way to paste them interleaved like what you wanted. However, you can create a temporary VBA to do what you want.

For example, you can:-

1. Create a VBA procedure (like the one below) in your Excel file.
2. Assign a keyboard shortcut (eg. Ctrl+Q) to it.
   • To do this, press Alt+F8, then select the macro, then click 'Options'.
3. Select the cells you want to copy, then press Ctrl+C.
4. Select the cell you want to paste in, then press Ctrl+Q (or whatever keyboard shortcut you chose).
5. Enter the number of times you want to copy. (In your example, it would be 3.)
6. WHAMMO! :D
7. Now you can delete the VBA procedure. :)

VBA Code:

Sub PasteAsInterleave()
    Dim startCell As Range
    Dim endCell As Range
    Dim firstRow As Range
    Dim pasteCount As Long
    Dim rowCount As Long
    Dim colCount As Long
    Dim i As Long
    Dim j As Long
    Dim inputValue As String

    If Application.CutCopyMode = False Then Exit Sub

    'Get number of times to copy.
    inputValue = InputBox("Enter number of times to paste interleaved:", _
                 "Paste Interleave", "")
    If inputValue = "" Then Exit Sub  'Cancelled by user.

On Error GoTo Error
    pasteCount = CInt(inputValue)
    If pasteCount <= 0 Then Exit Sub
On Error GoTo 0

    'Paste first set.
    ActiveSheet.Paste
    If pasteCount = 1 Then Exit Sub

    'Get pasted data information.
    Set startCell = Selection.Cells(1)
    Set endCell = Selection.Cells(Selection.Cells.count)
    rowCount = endCell.Row - startCell.Row + 1
    colCount = endCell.Column - startCell.Column + 1
    Set firstRow = Range(startCell, startCell.Offset(0, colCount - 1))

    'Paste everything else while rearranging rows.
    For i = rowCount To 1 Step -1
        firstRow.Offset(i - 1, 0).Copy

        For j = 1 To pasteCount
            startCell.Offset(pasteCount * i - j, 0).PasteSpecial
        Next j
    Next i

    'Select the pasted cells.
    Application.CutCopyMode = False
    Range(startCell, startCell.Offset(rowCount * pasteCount - 1, colCount - 1)).Select
    Exit Sub

Error:
    MsgBox "Invalid number."
End Sub