Excel vba macro copy rows multiple times based on a cell integer value
Solution 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
Solution 2
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
isLong
and the last row beingInteger+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
Admin
Updated on June 04, 2022Comments
-
Admin almost 2 years
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 | 2Output col1 | col2 | col3 | col4
dogs | like | cats
rats | like | nuts
rats | like | nuts
rats | like | nuts
cats | chew | rats
cats | chew | ratsValues in Output col4 could exist, doesn't matter for my case