Make 1 row into 4 rows

[Steph]

Hello. I have a ws with 500 rows of data. I need to convert each single
row into 4 identical rows (therefore making my data sheet now 2,000 rows).
Any idas?

 

[Tom Ogilvy]

No thoughts based on the information provided. Perhaps if you described
how the rows should be broken, someone might have some thoughts.

 

[Steph]

Fair enough. All I need to do is grab each line from the "Consolidated"
worksheet, copy it to the "Upload Data" worksheet 4 times, making 4
identical rows of data on "Upload Data" for every row of data in
"Consolidated". I have the following code to copy it once, but can't figure
out how to get it to make 4 pastes. Thanks!

Sub Copy_Four()
Dim destRange As Range
Dim cell As Range
Dim i As Integer
Set destRange = Worksheets("Upload Data").Cells( _
Rows.Count, 1).End(xlUp).Offset(1, 0)
With Worksheets("Consolidated")
For Each cell In .Range("A5:A" & _
.Range("A" & Rows.Count).End(xlUp).Row)
With cell
If Not IsEmpty(.Value) Then
.EntireRow.Copy destRange
Set destRange = destRange.Offset(1, 0)
End If
End With
Next cell
End With
End Sub

 

[Tom Ogilvy]

Sub Copy_Four()
Dim destRange As Range
Dim cell As Range
Dim i As Integer
Set destRange = Worksheets("Upload Data").Cells( _
Rows.Count, 1).End(xlUp).Offset(1, 0)
With Worksheets("Consolidated")
For Each cell In .Range("A5:A" & _
.Range("A" & Rows.Count).End(xlUp).Row)
With cell
If Not IsEmpty(.Value) Then
.EntireRow.Copy destRange.Resize(4,1)
Set destRange = destRange.Offset(4, 0)
End If
End With
Next cell
End With
End Sub

 

[Tim]

i *think* this is what you mean: -
======
Application.ScreenUpdating = False

For x = 1 To 500
ActiveCell.EntireRow.Select
Application.CutCopyMode = False
Selection.Copy
ActiveCell.Offset(1, 0).Rows("1:3").EntireRow.Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
ActiveCell.Offset(3, 0).Select
Next x

ActiveSheet.Range("A1").Select

Application.ScreenUpdating = True

==========
it takes a while to loop thru', but the ..screenupdating... hides all the
movements

hth,

tim

 

[Bernie Deitrick]

Steph,

Simply set your destination range to be four rows using Resize:

Change

Set destRange = Worksheets("Upload Data").Cells( _
Rows.Count, 1).End(xlUp).Offset(1, 0)

To

Set destRange = Worksheets("Upload Data").Cells( _
Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(4,1)

And change

Set destRange = destRange.Offset(1, 0)

to
Set destRange = destRange.Offset(4, 0).Resize(4, 1)


HTH,
Bernie
MS Excel MVP

 

[Steph]

Thanks guys!!

Steph,

Simply set your destination range to be four rows using Resize:

Change


To

Set destRange = Worksheets("Upload Data").Cells( _
Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(4,1)

And change


to
Set destRange = destRange.Offset(4, 0).Resize(4, 1)


HTH,
Bernie
MS Excel MVP