Macro to format all worksheets

[chumley]

Hi,

I'm looking to write a macro that will perform some simple formatting to every worksheet in a workbook. The problem I face is that the number of worksheets can vary from 1 to 200 and the names of the worksheets are also variable.

I have no clue how to go about this, could someone help me out please?

Thanks in advance.

 

[VoG]

Try like this

Sub Fmt()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    With ws
    '
    'do stuff
    .Range("A1:B7").Font.Bold = True
    '
    End With
Next ws
End Sub

 

[placebo2000]

This is something I use, I thought another example may help:

Sub FormatAllSheets()
    Dim j As Integer
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For j = 1 To Sheets.Count
        Sheets(j).Activate 
        
' Example format column A as date/time, starting at row 2 (all data down as long as continuous)
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
       With Selection
        .VerticalAlignment = xlCenter
        .HorizontalAlignment = xlCenter
        .NumberFormat = "dd-mmm-yy hh:mm:ss"
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
' format select from column B row 2 all data to the right and down
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .NumberFormat = "0.0"
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
  
      Next
            
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
 End Sub

 

[chumley]

Try like this

Sub Fmt()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    With ws
    '
    'do stuff
    .Range("A1:B7").Font.Bold = True
    '
    End With
Next ws
End Sub

Many thanks for the prompt response. When I use your example it works a treat, but when I add my own formatting in, instead of performing the action on each worksheet it performs the action mutiple times on the first worksheet only. Here is my code:

Sub Fmt()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    With ws
    '
    '
    Rows("1:6").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End With
Next ws
End Sub

Where am I going wrong?

 

[VoG]

Try

Sub Fmt()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    With ws
    '
    '
    .Rows("1:6").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End With
Next ws
End Sub

 

[chumley]

I've tried to take the macro that was provided and add in some additional formatting steps, but I can't get it to work as required. What I would like it to do:

1) Capture 2 pieces of information via an input box
2) Insert 4 rows at the top of each worksheet
3) Insert text in cells A1 and A2 that is aligned to the left of the cell
4) Insert an image in cell G1
5) Change the page set up to make each worksheet fit to 1 page wide and 1 tall

Here is the code as it stands:

Sub Statements()
    
    'Insert initial summary worksheet
    
    Worksheets.Add().Name = "Summary"
    
    'Get client name
    
    Response = InputBox("Please enter client name", "Input Box")
    
    'Get date
    
    Response2 = InputBox("Please enter date in the following format dd/mm/yy", "Input Box")
       
    
    'Format individual worksheets

    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        With ws
        '
        '
        .Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        
        .Range("A1").FormulaR1C1 = Response & " Call Account Statement as at " & Response2
        Range("A1").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
        
        .Range("A2").FormulaR1C1 = "Text in here"
        Range("A2").Select
        With Selection
            .HorizontalAlignment = xlLeft
        End With
        
        Range("G1").Select
        ActiveSheet.Pictures.Insert("c:\Logo.PNG").Select
        Set Emplacement = Range("G1")
        Set objImg = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count)

        With objImg.ShapeRange
            .LockAspectRatio = msoFalse
            .Left = Emplacement.Left
            .Top = Emplacement.Top
        End With
    
        With ActiveSheet.PageSetup
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        End With
    
    
        End With
    Next ws
      
    Sheets("Summary").Select
    Range("A5").Select

End Sub

The problems I am facing are:

1)The image is being inserted in to the first sheet only, and pasted multiple times on top of itself
2) The left justifiation of the text only happens on the first worksheet
3) The page set up of 1 wide by 1 tall is only being applied to the first worksheet

It would be much appreciated if someone could point me in the right direction. I appreciate that the code I have added isn't very elegant, I'm very much a VBA beginner.

 

[chumley]

It would be really appreciated if someone could help me out with this.

Thanks in advance.

 

[markmzz]

It would be really appreciated if someone could help me out with this.

Thanks in advance.

Chumley

Try this (I made small modifications to your code):

Sub Statements()
 
    'Insert initial summary worksheet
 
    Worksheets.Add().Name = "Summary"
 
    'Get client name
 
    Response = InputBox("Please enter client name", "Input Box")
 
    'Get date
 
    Response2 = InputBox("Please enter date in the following format dd/mm/yy", "Input Box")
 
 
    'Format individual worksheets
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            '
            '
            .Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
            .Range("A1").FormulaR1C1 = Response & " Call Account Statement as at " & Response2
            Range("A1").Select
            With Selection
                .HorizontalAlignment = xlLeft
            End With
 
            .Range("A2").FormulaR1C1 = "Text in here"
            Range("A2").Select
            With Selection
                .HorizontalAlignment = xlLeft
            End With
 
            Range("G1").Select
            .Pictures.Insert("c:\Logo.PNG").Select
            Set Emplacement = .Range("G1")
            Set objImg = .DrawingObjects(ActiveSheet.Shapes.Count)
 
            With objImg.ShapeRange
                .LockAspectRatio = msoFalse
                .Left = Emplacement.Left
                .Top = Emplacement.Top
            End With
 
            With .PageSetup
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
        End With
    Next ws
 
    Sheets("Summary").Select
    Range("A5").Select
End Sub

Markmzz

 

[chumley]

Thanks for your help Mark. Your code has fixed the problem with the images, but the left justification of the text and page set up issues have not been resolved.

Would you have any further ideas how I could tackle the remaining problems?

 

[markmzz]

Thanks for your help Mark. Your code has fixed the problem with the images, but the left justification of the text and page set up issues have not been resolved.

Would you have any further ideas how I could tackle the remaining problems?

Chumley,

Try this:

Sub Statements()
 
    'Insert initial summary worksheet
 
    Worksheets.Add().Name = "Summary"
 
    'Get client name
 
    Response = InputBox("Please enter client name", "Input Box")
 
    'Get date
 
    Response2 = InputBox("Please enter date in the following format dd/mm/yy", "Input Box")
 
 
    'Format individual worksheets
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        With ws
            '
            '
            .Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
 
            .Range("A1").FormulaR1C1 = Response & " Call Account Statement as at " & Response2
 
            With .Range("A1")
                .HorizontalAlignment = xlLeft
            End With
 
            .Range("A2").FormulaR1C1 = "Text in here"
            With .Range("A2")
                .HorizontalAlignment = xlLeft
            End With
 
            .Pictures.Insert("c:\Logo.PNG").Select
            Set Emplacement = .Range("G1")
            Set objImg = .DrawingObjects(ActiveSheet.Shapes.Count)
 
            With objImg.ShapeRange
                .LockAspectRatio = msoFalse
                .Left = Emplacement.Left
                .Top = Emplacement.Top
            End With
 
            With .PageSetup
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
        End With
    Next ws
 
    Range("A5").Select
End Sub

Markmzz