Macro to copy cells to rows below

[dancecommander81]

Hi,

I have a spreadsheet with 400+ rows of salon names in Column A.

I have the following macro to insert week numbers between each row,
however I would also like the name copying into the cells below the
original until the last week number when it changes to the next name.
Could someone please advise me of the changes I need to make to do
this?

Many thanks,

Richard Thorneycroft


Option Explicit
Sub AddListtoSalons()
'
' AddListtoSalons Macro
' Macro recorded 16/01/2006 by Rich T
'
Dim RowNdx As Long
Dim Arr As Variant
Dim StartRow As Long
Dim EndRow As Long
Application.ScreenUpdating = False
StartRow = 1
EndRow = Cells(Rows.Count, "A").End(xlUp).Row
Arr = Application.Transpose(Array("Week 1", "Week 2", "Week 3",
"Week 4", "Period 1", "Week 5", "Week 6", "Week 7", "Week 8", "Period
2", "Week 9", "Week 10", "Week 11", "Week 12", "Period 3", "Week 13",
"Week 14", "Week 15", "Week 16", "Period 4", "Week 17", "Week 18",
"Week 19", "Week 20", "Period 5", "Week 21", "Week 22", "Week 23",
"Week 24", "Period 6", "Week 25", "Week 26", "Week 27", "Week 28",
"Period 7", "Week 29", "Week 30", "Week 31", "Week 32", "Period 8",
"Week 33", "Week 34", "Week 35", "Week 36", "Period 9", "Week 37",
"Week 38", "Week 39", "Week 40", "Period 10", "Week 41", "Week 42",
"Week 43", "Week 44", "Period 11", "Week 45", "Week 46", "Week 47",
"Week 48", "Period 12", "Week 49", "Week 50", "Week 51", "Week 52",
"Period 13", ""))
For RowNdx = EndRow + 1 To StartRow + 1 Step -1
Rows(RowNdx).Resize(66).Insert
Cells(RowNdx, 3).Resize(66, 1).Value = Arr
Next RowNdx
Application.ScreenUpdating = True
End Sub

 

[Dave Peterson]

Try a little fiddling with:

For RowNdx = EndRow + 1 To StartRow + 1 Step -1
Rows(RowNdx).Resize(66).Insert
Cells(RowNdx, 3).Resize(66, 1).Value = Arr
With Cells(RowNdx, 1).Resize(65, 1)
.FormulaR1C1 = "=r[-1]c"
.Value = .Value
End With
With Cells(RowNdx, 1).Offset(65, 0)
.FormulaR1C1 = "=r[+1]c"
.Value = .Value
End With
Next RowNdx