Selection.Copy - ActiveSheet.Paste to blank cells

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

I’m looking for a macro routine that basically copies each of the "GUIDE
CAT." headers down through each blank cell below it next to each item (see
before & after below). I’m currently double clicking each header to copy
down. Then "End-Down" to the next set. The ActiveCell.Range needs to be
variable & run until all blanks are filled with the header from above.

Before:
GUIDE CATEGORY DESCRIPTION
BABY CARE
BABY BOTTLE 2PK 4Z
BABY BOTTLE CLEAR DECO 1PK 8 Z
BEAUTY CARE
BATH ACCESSERIES
ANIMAL BATH BUDDIES W/SUCTION
TITLED BATH BUFFER
COSMETIC/FRAGRANCE
BTY BASICS 6PC MKUP BRSH/MIRRO

After:
GUIDE CATEGORY DESCRIPTION
BABY CARE
BABY CARE BABY BOTTLE 2PK 4Z
BABY CARE BABY BOTTLE CLEAR DECO 1PK 8 Z
BEAUTY CARE
BATH ACCESSERIES
BATH ACCESSERIES ANIMAL BATH BUDDIES W/SUCTION
BATH ACCESSERIES TITLED BATH BUFFER
COSMETIC/FRAGRANCE
COSMETIC/FRAGRANCE BTY BASICS 6PC MKUP BRSH/MIRRO


MACRO:
Range("B1").Select
Selection.End(xlDown).Select
Selection.Copy
ActiveCell.Offset(1, 0).Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveCell.Range("A1:A61").Select
ActiveSheet.Paste
‘ (repeats until all blank cells are filled w/header from above)
End Sub
 
Something like this should work. Your specific setup will dictate any
modifications.

Sheets("sheet1").activate
Range("A1").activate
retval = activecell
For each cell in Sheets
Do
If Activecell = "" And Activecell.offset(0,1) = "" then
exit for
elseIf Activecell = "" then
Activecell = retval
else
Activecell.offset(1,0).activate
Loop
Do
Next
End Sub
 
I copied & pasted your script into a test macro & received an error message.
"Compile Error: Loop without Do".
 
You must log in or register to reply here.
Back
Top