VBA - Apply Format and Page Layout to all new worksheets

jws

Board Regular
Joined
Jan 10, 2008
Messages
69
Hello,

I have two macros - the first one being the most important, is where this creates new worksheets based off a change in Column A on the Summary tab. This will create roughly 40 worksheets. How do I get the format macro included into Macro 1?

If this is unclear please let me know, thanks for looking.

Macro 1
Sub columntosheets()

Const sname As String = "Summary" 'change to whatever starting sheet
Const s As String = "A" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh

Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate

End Sub

Now for the Format macro that I want applied to all 40 worksheets since it will allow the end users to print accordingly


Sub Format()
'
' Format Macro
'

'
Columns("A:M").Select
Columns("A:M").EntireColumn.AutoFit
Range("J1").Select
Columns("J:J").ColumnWidth = 11.57
Columns("M:M").Select
Selection.ColumnWidth = 11.86
ActiveWindow.DisplayGridlines = False
Columns("D:M").Select
Columns("D:M").EntireColumn.AutoFit
Range("M1").Select
ActiveSheet.PageSetup.PrintArea = "$M$1"
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.PageSetup.PrintArea = "$A$1:$M$81"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$A$1:$M$81"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 7
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$A$1:$M$81"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 7
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveWindow.View = xlPageBreakPreview
ActiveWindow.Zoom = 85
ActiveSheet.ResetAllPageBreaks
Set ActiveSheet.HPageBreaks(1).Location = Range("A42")
ActiveWindow.SmallScroll Down:=-27
End Sub
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
I am not thinking it will work in one macro, so with that said, is there a way to apply the "format" macro to all worksheets in the workbook? The worksheet names and number of worksheets will vary from week to week, so the code would have to accomodate that.
 
Upvote 0
I found that this works in applying my format macro to all tabs, so that is how I solved this:

Sub AllSheets()
Dim ws As Worksheet
For Each ws In Worksheets
'--put your row insert code here--'
Next ws
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top