Excel vba macro copy rows multiple times based on

Question

I am looking for a VBA Excel macro that copies complete rows to another work sheet. It would need to create additional duplicate copies of that row based on a cell integer value.

This is helpful when using a mail merge where you want to create multiple copies of a document or label. I've found several answers which are close, but nothing that copies full rows

Input
col1 | col2 | col3 | col4
dogs | like | cats | 1
rats | like | nuts | 3
cats | chew | rats | 2

Output col1 | col2 | col3 | col4
dogs | like | cats
rats | like | nuts
rats | like | nuts
rats | like | nuts
cats | chew | rats
cats | chew | rats

Values in Output col4 could exist, doesn't matter for my case

Answer 1

Assuming the sheet with the data has the name 'Sheet1', the output sheet has the name 'Sheet2' and the amount of times to duplicate is located in row D - this code will work. You'll need to modify it to suit your needs first!

Sub DuplicateRows()

Dim currentRow As Integer
Dim currentNewSheetRow As Integer: currentNewSheetRow = 1

For currentRow = 1 To 3 'The last row of your data

    Dim timesToDuplicate As Integer
    timesToDuplicate = CInt(Sheet1.Range("D" & currentRow).Value2)

    Dim i As Integer
    For i = 1 To timesToDuplicate

        Sheet2.Range("A" & currentNewSheetRow).Value2 = Sheet1.Range("A" & currentRow).Value2
        Sheet2.Range("B" & currentNewSheetRow).Value2 = Sheet1.Range("B" & currentRow).Value2
        Sheet2.Range("C" & currentNewSheetRow).Value2 = Sheet1.Range("C" & currentRow).Value2

        currentNewSheetRow = currentNewSheetRow + 1

    Next i

Next currentRow

End Sub

Answer 2

I adapted Francis' answer to work from the current active spreadsheet and only on selected rows. My particular use case required changing the quantity to 1 for each duplication hence the "G" column being set to 1.

It still only works on a fixed set of columns.

Sub MultiplySelectedRows()
'store reference to active sheet
Dim Source As Worksheet
Set Source = ActiveWorkbook.ActiveSheet
'create new sheet for output
Dim Multiplied As Worksheet
Set Multiplied = Sheets.Add(After:=Worksheets(Worksheets.Count))
'switch back to original active sheet
Source.Activate
Dim rng As Range
Dim lRowSelected As Long
Dim duplicateCount As Integer
Dim newSheetRow As Integer
newSheetRow = 1
For Each rng In Selection.Rows
    lRowSelected = rng.Row
    'Column holding number of times to duplicate each row is specified in quotes
    duplicateCount = CInt(Source.Range("G" & lRowSelected).Value)
    Dim i As Integer
    For i = 1 To duplicateCount
        'one copy statement for each column to be copied
        Multiplied.Range("A" & newSheetRow).Value = Source.Range("A" & lRowSelected).Value
        Multiplied.Range("B" & newSheetRow).Value = Source.Range("B" & lRowSelected).Value
        Multiplied.Range("C" & newSheetRow).Value = Source.Range("C" & lRowSelected).Value
        Multiplied.Range("D" & newSheetRow).Value = Source.Range("D" & lRowSelected).Value
        Multiplied.Range("E" & newSheetRow).Value = Source.Range("E" & lRowSelected).Value
        Multiplied.Range("F" & newSheetRow).Value = Source.Range("F" & lRowSelected).Value
        'multiplier is replaced by 1 (16x1 instead of 1x16 lines)
        Multiplied.Range("G" & newSheetRow).Value = 1
        Multiplied.Range("H" & newSheetRow).Value = Source.Range("H" & lRowSelected).Value
        Multiplied.Range("I" & newSheetRow).Value = Source.Range("I" & lRowSelected).Value
        Multiplied.Range("J" & newSheetRow).Value = Source.Range("J" & lRowSelected).Value
        Multiplied.Range("K" & newSheetRow).Value = Source.Range("K" & lRowSelected).Value
        Multiplied.Range("L" & newSheetRow).Value = Source.Range("L" & lRowSelected).Value
        newSheetRow = newSheetRow + 1
    Next i
Next rng

End Sub

Answer 3

I've made some changes and adjusted Francis Dean's answer:

• For those on Office 2013 (or 2010?), Excel needs to know explicitly that "Sheet1" is the name of a Sheet.
• Also I adapted the macro for more columns and rows. For example currentRow is Long and the last row being Integer+1.
• My integer value to determine duplicating is in "J".

The macro is then:

Sub DuplicateRows()
    Dim currentRow As Long
    Dim currentNewSheetRow As Long: currentNewSheetRow = 1

    For currentRow = 1 To 32768 'The last row of your data
    Dim timesToDuplicate As Integer
    timesToDuplicate = CInt(Worksheets("Sheet1").Range("J" & currentRow).Value)
    Dim i As Integer
    For i = 1 To timesToDuplicate
        Worksheets("Sheet2").Range("A" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("A" & currentRow).Value
        Worksheets("Sheet2").Range("B" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("B" & currentRow).Value
        Worksheets("Sheet2").Range("C" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("C" & currentRow).Value
        Worksheets("Sheet2").Range("D" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("D" & currentRow).Value
        Worksheets("Sheet2").Range("E" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("E" & currentRow).Value
        Worksheets("Sheet2").Range("F" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("F" & currentRow).Value
        Worksheets("Sheet2").Range("G" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("G" & currentRow).Value
        Worksheets("Sheet2").Range("H" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("H" & currentRow).Value
        Worksheets("Sheet2").Range("I" & currentNewSheetRow).Value = Worksheets("Sheet1").Range("I" & currentRow).Value
        currentNewSheetRow = currentNewSheetRow + 1
    Next i
Next currentRow
End Sub