Macro Creates Mult Sheets Based on Summary

A

abergman

Alright,
So I'm working on a macro that takes info from my summary sheet (Names and
Numbers) and breaks out each one into its own sheet and formats the sheet
using those names and numbers in the headers. So far, I can figure out how to
break out the sheets, but I'm running into problems with the formatting for
some reason!
This is what I have for the new sheet creation and naming:
Sub Macro1()
Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("INPUT").Range("F3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub

Easy enough.
For the formatting, I'm trying to add this in before the 'Next MyCell', but
I keep getting errors.

For Each MyCell In MyRange
With Sheets(MyCell.Value).PageSetup
.LeftHeader = ""
.CenterHeader = MyCell.Offset(0, -3).Name & vbLf & "Number" &
MyCell.Offset(0, -2).Name & vbLf & "TEXT"
.TopMargin = Application.InchesToPoints(0.99)
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
With ActiveSheet.Range("a2", "b2", "c2", "d2", "e2", "f2", "g2",
"h2").Select.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.Font
.Name = "Cambria"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
With Range("a2").FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
End With
Next MyCell
End Sub

I don't think its liking the pagesetup or the "next mycell" at the end. I
have no idea.... Any clues as to what is going on, or suggestions on
different code to use??
 
D

Dave Peterson

Check your earlier post.
Alright,
So I'm working on a macro that takes info from my summary sheet (Names and
Numbers) and breaks out each one into its own sheet and formats the sheet
using those names and numbers in the headers. So far, I can figure out how to
break out the sheets, but I'm running into problems with the formatting for
some reason!
This is what I have for the new sheet creation and naming:
Sub Macro1()
Dim MyCell As Range, MyRange As Range

Set MyRange = Sheets("INPUT").Range("F3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell
End Sub

Easy enough.
For the formatting, I'm trying to add this in before the 'Next MyCell', but
I keep getting errors.

For Each MyCell In MyRange
With Sheets(MyCell.Value).PageSetup
.LeftHeader = ""
.CenterHeader = MyCell.Offset(0, -3).Name & vbLf & "Number" &
MyCell.Offset(0, -2).Name & vbLf & "TEXT"
.TopMargin = Application.InchesToPoints(0.99)
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
With ActiveSheet.Range("a2", "b2", "c2", "d2", "e2", "f2", "g2",
"h2").Select.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.Font
.Name = "Cambria"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
With Range("a2").FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
ActiveCell.Offset(0, 1).FormulaR1C1 = "TEXT"
End With
Next MyCell
End Sub

I don't think its liking the pagesetup or the "next mycell" at the end. I
have no idea.... Any clues as to what is going on, or suggestions on
different code to use??
Click to expand...
 
P

Per Jessen

Hi

Assuming that the workbook only contain the "INPUT" sheet before the macro
is ran, try this:

Sub Macro1()
Dim MyCell As Range, MyRange As Range
Dim Counter As Long, HeaderCell As Range

Application.ScreenUpdating = False

Set MyRange = Sheets("INPUT").Range("F3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))

For Each MyCell In MyRange
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
Next MyCell

Set HeaderCell = Sheets("INPUT").Range("F3")
For Each sh In ThisWorkbook.Sheets
If sh.Name <> "INPUT" Then
With sh.PageSetup
.LeftHeader = ""
.CenterHeader = HeaderCell.Offset(0, -3).Value & vbLf & "Number"
_
& HeaderCell.Offset(0, -2).Value & vbLf & "TEXT"
.TopMargin = Application.InchesToPoints(0.99)
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
Set MyRange = sh.Range("A2:H2")
With MyRange.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With MyRange.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With MyRange.Font
.Name = "Cambria"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
With sh.Range("a2")
.FormulaR1C1 = "TEXT"
.Offset(0, 1).FormulaR1C1 = "TEXT"
.Offset(0, 2).FormulaR1C1 = "TEXT"
.Offset(0, 3).FormulaR1C1 = "TEXT"
.Offset(0, 4).FormulaR1C1 = "TEXT"
.Offset(0, 5).FormulaR1C1 = "TEXT"
.Offset(0, 6).FormulaR1C1 = "TEXT"
.Offset(0, 7).FormulaR1C1 = "TEXT"
End With
Set HeaderCell = HeaderCell.Offset(1, 0)
End If

Next
Application.ScreenUpdating = True
End Sub

Regards,
Per
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

A Macro for Multiple Sheets that Reference one Summary Page 1
Create Sheets from a Range and Copy Data on copy Data on newlycreated Sheets with the Sheet Names 2
Sorting Problem 2
Border formatting row of cells 22
Macro Error 1
Macro help 0
Help with mess of code 1
Trouble selecting multiple sheets using RDB code 13

Top