Macro to insert copied cells

[dancecommander81]

Hi,

A colleague has a spreadsheet with a list of 400 salon names in Column
A. She wants to add a list of sub headings, also in Column A, beneath
each salon name. There are 16 items on the list and one blank cell
before the next salon name. I have written a Macro to copy the initial
cells from below the first salon name (A2:A18) and insert them below
the second salon name.

Range("A2:A18").Select
Selection.Copy
Range("A20").Select
Selection.Insert Shift:=xlDown
ActiveWindow.SmallScroll Down:=-3

How do I now get this to insert it after each salon name?

I hope someone can help!

Many thanks,

Richard Thorneycroft

 

[dancecommander81]

After much trial and error doing a little more research I've come up
with this, for a test of just 8 salon names...

Dim RowNdx As Long
Dim Arr As Variant
Dim StartRow As Long
Dim EndRow As Long
StartRow = 1 '<<< CHANGE to appropriate row number
EndRow = 8 '<<< CHANGE to appropriate row number
Arr = Application.Transpose(Array("Hair Service", "Hair Retail", "Total
Hair", "Beauty Service", "Beauty Retail", "Total Beauty", "Total",
"Colour Number", "Treatment Number", "Facial Number", "Waxing Number",
"Hair Service Customer No", "Beauty Service Customer No", "Hair CF
Count", "Beauty CF Count", ""))
For RowNdx = StartRow + 1 To (EndRow) * 16 Step 17
Rows(RowNdx).Resize(16).Insert
Cells(RowNdx, 1).Resize(16, 1).Value = Arr
Next RowNdx

Could some one let me know if this is correct, it seems to work fine on
a test of 8 salon names, but I'm not sure if it's the best way of
getting the job done.

Cheers,

Rich

 

[Ken Johnson]

Hi Rich,
Don't ask me why but I had to change EndRow = 8 to EndRow = 425 for all
400 salons to be done. Trial and error got me there. Loops are always
hard to follow.
To speed things up a bit I threw in "Application.ScreenUpdating =
False" at the start to prevent all the screen flashing. It can be put
anywhere in the code so long as it's before the Loop.
Ken Johnson

 

[Don Guillett]

You can determine a variable end row by

endrow=cells(rows.count,"a").end(xlup).row

change the "a" to the column desired.

 

[dancecommander81]

Thanks for that Don.

However I can't seem to get the
endrow=cells(rows.count,"a").end(xlup).row line to fundtion correctly.

My code looks like this and it leaves 23 salons not done.


Sub InsertValuesBelowCells()


'
' Macro3 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("Hair Service", "Hair Retail", "Total
Hair", "Beauty Service", "Beauty Retail", "Total Beauty", "Total",
"Colour Number", "Treatment Number", "Facial Number", "Waxing Number",
"Hair Service Customer No", "Beauty Service Customer No", "Hair CF
Count", "Beauty CF Count", ""))
For RowNdx = StartRow + 1 To (EndRow) * 16 Step 17
Rows(RowNdx).Resize(16).Insert
Cells(RowNdx, 1).Resize(16, 1).Value = Arr
Next RowNdx


'
End Sub

 

[dancecommander81]

Hi Ken,

Thanks for the screen updating tip. However, I can't get it to run to
the right place, it seems however I try it it always leaves 23 salons
unfinished.

I tried Don's suggestion below and your 425. I also tried other
numbers, but still 23 lines were left untouched!?

Any ideas where I am going wrong?

Thanks again.

Rich

 

[dancecommander81]

Hi Guys,

Hust a little more info.

The macro below works fine until the number of rows increases. I've
tried it with up to 15 rows and it works fine, anything over that and
it doesn't finish the range. It seems the more rows, the more it leaves
untouched, but I can't see a pattern. With 16 rows it leaves 1 not done
and the same with 30 rows. With 50 rows it leaves 3, but with 400 rows
it leaves 23 not done?!?

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("Hair Service", "Hair Retail", "Total

Hair", "Beauty Service", "Beauty Retail", "Total Beauty", "Total",
"Colour Number", "Treatment Number", "Facial Number", "Waxing Number",
"Hair Service Customer No", "Beauty Service Customer No", "Hair CF
Count", "Beauty CF Count", ""))
For RowNdx = StartRow + 1 To (EndRow) * 16 Step 17
Rows(RowNdx).Resize(16).Insert
Cells(RowNdx, 1).Resize(16, 1).Value = Arr
Next RowNdx

 

[Dave Peterson]

Life will be lots easier if you start at the bottom and work up the range.

Same thing when you're deleting rows, too:

Option Explicit
Sub testme()
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("Hair Service", "Hair Retail", _
"Total Hair", "Beauty Service", "Beauty Retail", _
"Total Beauty", "Total", "Colour Number", "Treatment Number", _
"Facial Number", "Waxing Number", "Hair Service Customer No", _
"Beauty Service Customer No", "Hair CF Count", "Beauty CF Count", ""))
For RowNdx = EndRow To StartRow + 1 Step -1
Rows(RowNdx).Resize(16).Insert
Cells(RowNdx, 1).Resize(16, 1).Value = Arr
Next RowNdx
Application.ScreenUpdating = True
End Sub

 

[dancecommander81]

Cheers Dave,

That seems to work great.

Thanks for your help.

Rich

 

[Ken Johnson]

Hi Rich,
I can confirm the 23 undone salons using EndRow =
Cells(Rows.Count,"A".End(xlUp).Row,
however, I get all 400 salons done using EndRow = 425.
Beats me what's going wrong at your end. I pasted the code from your
last reply and just changed the EndRow.
Ken Johnson

 

[Ken Johnson]

Hi Dave,
Testme leaves one salon left undone.
If....
For RowNdx = StartRow + 1 To (EndRow) * 16 Step 17

in Rich's last reply is changed to...

For RowNdx = StartRow + 1 To (EndRow) * 17 Step 17

then all 400 salons are done.

Ken Johnson

 

[Dave Peterson]

Untested:

For RowNdx = EndRow To StartRow + 1 Step -1
Rows(RowNdx+1).Resize(16).Insert
Cells(RowNdx+1, 1).Resize(16, 1).Value = Arr
Next RowNdx

or

For RowNdx = EndRow + To StartRow + 1 Step -1
Rows(RowNdx).Resize(16).Insert
Cells(RowNdx, 1).Resize(16, 1).Value = Arr
Next RowNdx

 

[Dave Peterson]

That second one (still untested) should be:

For RowNdx = EndRow + 1 To StartRow + 1 Step -1
Rows(RowNdx).Resize(16).Insert
Cells(RowNdx, 1).Resize(16, 1).Value = Arr
Next RowNdx

 

[dancecommander81]

Hi Dave,

The second one seems to work (the first missed out the 1st row)

Any everyone, thanks for all of your help.

Hopefully this will help someone else too someday

Thanks again,

Rich

 

[Dave Peterson]

You can always adjust this line:

For RowNdx = EndRow + 1 To StartRow + 1 Step -1
to
For RowNdx = EndRow + 1 To StartRow Step -1

to get the first row.

 

[dancecommander81]

Hi Guys,

That worked great for what the user needed.

However, as she was so impressed she now wants another to do something
very similar this time she has columns A and B both containing 400 or
so salon names (the columns contents are identical, but B will later be
hidden, something to do with vlookup).

She would like week numbers entering in to column C for each salon.
I've used the same macro as before, see below, but I can't get the data
to be entered in to column C. It always enters in to A.

Sorry to keep on.

Hope you can help, again!

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, "C").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, 1).Resize(66, 1).Value = Arr
Next RowNdx
Application.ScreenUpdating = True
End Sub

 

[Ken Johnson]

Hi Rich,

Just a quick thought, I think it's because in the second line in the
for next loop, the column references of the Cells thingy is 1 (1 = col
A) and should probably be 3 (3 = Col C), so try " Cells(RowNdx,
3).Resize(66, 1).Value = Arr " there.
I think the Resize(66,1) stays rather than changing to Resize(66,3), ut
do't quote me.

Ken Johnson

 

[Ken Johnson]

Hi Rich,
Only worked on first salon, so I changed:

"EndRow = Cells(Rows.Count, "C").End(xlUp).Row" back to...

"EndRow = Cells(Rows.Count, "A").End(xlUp).Row" then it worked for all
salons, but I'm only guessing that the worksheet this new macro is
working on is the same as the worksheet your original macro worked on.

Ken Johnson