Duplicate rows based on cell value [Solved/Closed]

Posts
28
Registration date
Monday February 3, 2014
Last seen
June 23, 2014
- Feb 3, 2014 at 01:31 AM - Latest reply:
Posts
2447
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 15, 2018
- Mar 13, 2014 at 12:07 PM
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 

16 replies

Posts
2447
Registration date
Sunday September 12, 2010
Status
Contributor
Last seen
November 15, 2018
- Feb 3, 2014 at 12:11 PM
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
Posts
2447
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 15, 2018
- Mar 10, 2014 at 11:32 AM
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
Posts
28
Registration date
Monday February 3, 2014
Last seen
June 23, 2014
- Mar 12, 2014 at 02:24 PM
HI,

Thank you for always there to help me out. I owe you a beer :-)
It worked.
Posts
10861
Registration date
Monday June 3, 2013
Status
Moderator
Last seen
November 17, 2018
- Mar 12, 2014 at 04:53 PM
@TrowaD--Your code is always so neatly formatted! Managers Dream! Way to go!
Posts
2447
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 15, 2018
- Mar 13, 2014 at 12:05 PM
Thanks Fireburn, looking forward to it!
Posts
2447
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
November 15, 2018
- Mar 13, 2014 at 12:07 PM
And thanks to you Mark.

I have great respect for you, so it means a lot to me!
Posts
28
Registration date
Monday February 3, 2014
Last seen
June 23, 2014
- Feb 12, 2014 at 10:05 AM
0
Thank you
Thank you for helping me out. Greatly appreciate it.