Is it possible?

Underdog85

New Member
Joined
Apr 8, 2019
Messages
2
Hi,

Not an advanced user of excel before so hoping someone can help out with this.

I have a file with approx 1500 rows and approx 10 columns

I need to automate to do the following:

Select a row (row 1) duplicate it underneath as a new row (row 2)
move to the next unique row (row 3) and duplicate (row 4)
move to the next unique row (row 5) and duplicate (row 6)
REPEAT
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Hi, welcome to the board! Here is some VBA code that you can try on a copy of your workbook.

Code:
Sub DuplicateRows()


Dim lc As Long, lr As Long


Application.ScreenUpdating = False


lc = Cells(1, Columns.Count).End(xlToLeft).Column
lr = Cells(Rows.Count, "A").End(xlUp).Row


With Cells(1, lc + 1).Resize(lr)
    .Formula = "=row()"
    .Value = .Value
    With .Resize(lr).Offset(, -lc).Resize(, lc + 1)
        .Copy Destination:=.Offset(lr)
        .Resize(lr * 2).Sort key1:=.Cells(1, lc + 1), order1:=xlAscending, Header:=xlNo
    End With
    .EntireColumn.Delete
End With


End Sub
 
Upvote 0
Code from @FormR (which adds a sequence flag , duplicates the data , sorts and deletes the flag ) will run faster

This does things one row at a time, starting from the bottom
- assmes that there is a value in column A in the last row

Code:
Sub DupRows()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim r As Long
    With ActiveSheet
        For r = .Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
            .Rows(r).Copy
            .Cells(r + 1, 1).Insert Shift:=xlDown
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
Thanks for the welcome and the code.

Initial tests on a small batch were successful so thanks!

Seen as that was pretty simple I have another question.

On the duplicated rows only could the code change the data inside the cells on a specific column? So for example change all the data in each cell in the column named 'Variant Price' to 0.00?
 
Upvote 0
So for example change all the data in each cell in the column named 'Variant Price' to 0.00?

Hi, do we know in advance which column this is, as in its always column C for example, or do we need to dynamically find it?
 
Upvote 0
This puts 0 in column E
- amend to the correct column

Code:
Sub DupRows()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim r As Long
    With ActiveSheet
        For r = .Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
            .Rows(r).Copy
            .Cells(r + 1, 1).Insert Shift:=xlDown
            .Cells(r + 1, [COLOR=#ff0000]5[/COLOR]).Value = 0
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
End Sub

If Variant Price column is one of headers in row 1 and could be any one of the columns , VBA can find it like this ...
Code:
Sub DupRows()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Dim r As Long, [COLOR=#ff0000]vp[/COLOR] As Long
    With ActiveSheet
        [COLOR=#ff0000]vp[/COLOR] = .Rows(1).Find("Variant Price").Column
        For r = .Range("A" & Rows.Count).End(xlUp).Row To [COLOR=#ff0000]2[/COLOR] Step -1
            .Rows(r).Copy
            .Cells(r + 1, 1).Insert Shift:=xlDown
            .Cells(r + 1, [COLOR=#ff0000]vp[/COLOR]).Value = 0
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,445
Messages
6,172,181
Members
452,447
Latest member
willsing5130

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top