VBA to duplicate

[mattless1]

Hi,

I have a workbook with sheet1, which i would like to duplicate the data in the next empty row.
i have a range of data lets say from column A to D and the amount of data changes it could be 10 rows or 20 rows. id like to duplicate this data in the next empty row. i would need to do this a few times if its possible to do this & if its possible can there be a cell to enter a number of times its duplicated? is it possible to color code each copy to differentiate each one. if it can't be done with VBA is there a better way to achieve it.

Many thanks for any advice
Mattless1

 

[My Aswer Is This]

So let me see if I understand.

You have a row of data that you want duplicated a certain number of times.
So lets say you double click on any cell in column A and that entire row of data is duplicated on the next empty row in the same sheet.
Using column A to determine the last filled cell in the row.
And I have a Inputbox popup asking how many times to duplicate the row
Would something like that work?
And do you have formulas in any of these cells. Because if you do the formulas now may have difficulty depending on the formula.

Now if you want to duplicate 20 rows all at once how would I know what rows?

 

[My Aswer Is This]

If something like that would work try this
This is an auto sheet event script
Your Workbook must be Macro enabled
To install this code:
Right-click on the sheet tab
Select View Code from the pop-up context menu
Paste the code in the VBA edit window

When you double click on any cell in column A the script will run

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Modified  4/16/2022  3:57:23 PM  EDT
If Target.Column = 1 Then
    Cancel = True
    Dim ans As Long
    Dim Lastrow As Long
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Dim r As Long
    r = Target.Row
    ans = InputBox("Enter how many copies of the current row you want duplicated")
    Rows(Lastrow).Resize(ans).Value = Rows(r).Value
End If
End Sub

 

[mattless1]

If something like that would work try this
This is an auto sheet event script
Your Workbook must be Macro enabled
To install this code:
Right-click on the sheet tab
Select View Code from the pop-up context menu
Paste the code in the VBA edit window

When you double click on any cell in column A the script will run

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Modified  4/16/2022  3:57:23 PM  EDT
If Target.Column = 1 Then
    Cancel = True
    Dim ans As Long
    Dim Lastrow As Long
    Lastrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
    Dim r As Long
    r = Target.Row
    ans = InputBox("Enter how many copies of the current row you want duplicated")
    Rows(Lastrow).Resize(ans).Value = Rows(r).Value
End If
End Sub

Hi,
thank you for taking the time to reply, the code you've provided does copy the first row perfectly, but I'm looking to copy a range of data multiple rows that could change and colour each copy a different colour so i can see each copy.

many thanks,

 

[footoo]

Assuming the data to be copied starts in row 1 :

Sub v()
Dim ans%, colorCodes, rng As Range, r%, c%, x%, dest As Range
ans = InputBox("Enter how many copies of the current row you want replicated")
'Change the color codes as required.
colorCodes = Array(4, 6, 7, 8, 15, 17, 19, 20)
Set rng = Range("A1:D" & Cells(Rows.Count, "A").End(3).Row)
r = rng.Rows.Count
c = rng.Columns.Count
For x = 1 To ans
    Set dest = Cells(Rows.Count, "A").End(3)(2)
    rng.Copy dest
    dest.Resize(r, c).Interior.ColorIndex = colorCodes(x)
Next
End Sub

 

[footoo]

Edited :

Sub v()
Dim ans%, colorCodes, rng As Range, r%, c%, x%, dest As Range
ans = InputBox("Enter how many copies of the data you want replicated")
'Change the color codes as required.
colorCodes = Array(4, 15, 17, 19)
Set rng = Range("A1:D" & Cells(Rows.Count, "A").End(3).Row)
r = rng.Rows.Count
c = rng.Columns.Count
For x = 0 To ans - 1
    Set dest = Cells(Rows.Count, "A").End(3)(2)
    rng.Copy dest
    dest.Resize(r, c).Interior.ColorIndex = colorCodes(x)
Next
End Sub

 

[mattless1]

Hi Footoo,

thank you for the code it is working for me i really appreciate that.

Many thanks.