Dave,

Not sure how your data is laid out but if all your entries are in one
column, the macro below will seperate each existing row and copy and paste
the data into six cells below same. I've tested this to about 7000 rows with
no problem but try it on a copy of your WS just to be safe.

Option Explicit

Sub AddSixRows()

Dim i, t As Long
Dim LastRow As Long
On Error Resume Next

' find the last row used
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

' select the last cell used
Range("A" & LastRow).Select

' insert 6 rows between each cell from last cell up
For t = LastRow - 1 To 1 Step -1
For i = 1 To 6
Selection.EntireRow.Insert
Next
Range("A" & t).Select
Next

' find the current last row used
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

' copy data to the six empty rows
For i = 1 To LastRow Step 7
Range("A" & i).Select
Selection.Copy
For t = 1 To 6
Selection.Offset(1, 0).Select
ActiveSheet.Paste
Next
Next

' cut copy mode
Application.CutCopyMode = False

End Sub

HTH,

Don
"Dave" wrote:

I have a spreadsheet of items and their sizes. Each item has 7 sizes. I need
to add 6 rows under each item and copy the data from the from the first row.
There are 150 items in the spreadsheet and I basically need to create a macro
to copy each item 6 times right underneath the original item.

I'm not very familiar with macros. When I started trying this, I just kept
getting the macro to create the same row over and over.

Any help would be greatly appreciated.