Menu
Ask a question Report

Duplicate rows based on cell value [Solved/Closed]

Posts
28
Registration date
Monday February 3, 2014
Last seen
June 23, 2014
 - - Latest reply: TrowaD
Posts
2448
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
February 14, 2019
 - Mar 13, 2014 at 12:07 PM
Excel Ask a question Report
Hi,

Can somebody help me out with this. I want to duplicate rows based on input in a cell. can it be done in VB or macro or formula array? User will only input value in a cell (e.g. F1)

A B C D E F (eg F1 is the input cell)
1 2 3 4 5 2

and should look like this after inputting value in F1

A B C D E F
1 2 3 4 5 2
1 2 3 4 5
1 2 3 4 5

Thank you.
See more 

2 replies

Report Respond to TrowaD
Posts
2448
Registration date
Sunday September 12, 2010
Status
Contributor
Last seen
February 14, 2019
 409
0
Thank you
Hi Fireburn,

Try this code and let me know how it works: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Integer

If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub
If IsNumeric(Target.Value) = False Then Exit Sub
If Target.Value = 0 Then Exit Sub
If Target.Value = vbNullString Then Exit Sub

x = Target.Value

Do
    Range(Cells(Target.Row, "A"), Cells(Target.Row, "E")).Copy
    Range(Cells(Target.Row + 1, "A"), Cells(Target.Row + 1, "E")).Insert Shift:=xlDown
    x = x - 1
Loop Until x = 0

Application.CutCopyMode = False
End Sub

Best regards,
Trowa
View all 14 comments
Report
TrowaD
Posts
2448
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
February 14, 2019
 409 -
Hi Fireburn,

For that use the following code: 
Sub RunMe()
Dim ws As Worksheet

For Each ws In Worksheets
    If ws.Name <> "Master" Then
        ws.Activate
        For Each cell In Range("C:C")
            If cell.Value <> vbNullString Then
                Range(Cells(cell.Row, "C"), Cells(cell.Row, "M")).Copy _
                Sheets("Master").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        Next cell
    End If
Next ws

Sheets("Master").Activate

End Sub

Best regards,
Trowa
Report
fireburn
Posts
28
Registration date
Monday February 3, 2014
Last seen
June 23, 2014
 -
HI,

Thank you for always there to help me out. I owe you a beer :-)
It worked.
Report
ac3mark
Posts
11440
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
February 22, 2019
 2164 -
@TrowaD--Your code is always so neatly formatted! Managers Dream! Way to go!
Report
TrowaD
Posts
2448
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
February 14, 2019
 409 -
Thanks Fireburn, looking forward to it!
Report
TrowaD
Posts
2448
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
February 14, 2019
 409 -
And thanks to you Mark.

I have great respect for you, so it means a lot to me!
Report Respond to fireburn
Posts
28
Registration date
Monday February 3, 2014
Last seen
June 23, 2014
0
Thank you
Thank you for helping me out. Greatly appreciate it.
Ask a question