XL97:Suggestions on speeding up this code?

[XL Pro]

At the junction of this routine, the workbook has about 20 worksheets. Any suggestions on what I can do to speed it up?

Note: if you see a variable not DIMmed it's a global variable

Sub CleanUpSheets()
    Dim SkillSheet As Worksheet
    Dim fRange As Range
    Dim LastRow As Long
    Dim Col401K As Integer
    Dim LastCol As Integer
    Dim BegCol As Integer
    Dim EmpCol As Integer
    Dim SSNCol As Integer
    Dim Idx As Integer
    Dim MaxCount As Integer
    Dim CRLF As String
    Dim LftHeader As String
    Dim RhtHeader As String
    
    CRLF = Chr$(10)
    LftHeader = "&""Arial,Bold""&10" & CompanyName & "/"
    If CompanyAddr2 <> "" Or CompanyAddr2 <> "<" Then
        CompanyAddr2 = "<"
    End If
    LftHeader = LftHeader & CompanyAddr1 & "/" & IIf(Left$(CompanyAddr2, 1) <> "<", CompanyAddr2 & "/", "")
    LftHeader = LftHeader & CompanyCity & ", " & CompanyState & "  " & CompanyZip & CRLF & CRLF
    LftHeader = LftHeader & "&""Arial,Bold""&8" & "EMPLOYER: " & CompanyNumber

    RhtHeader = "&""Arial,Bold""&10" & "SOUTHERN CALIFORNIA PIPE TRADES" & CRLF
    RhtHeader = RhtHeader & "UNION REPORTS" & CRLF
    RhtHeader = RhtHeader & Format$(RunDate, "MMMM/YYYY")

    
    MaxCount = UnionBook.Worksheets.count
    
    Windows(UnionBook.Name).Visible = True
    ProgressBar.Show
    For Each SkillSheet In UnionBook.Worksheets
        With SkillSheet
            Idx = .Index
            ProgressBar.SetText "Setting Print Area...." & .Name & CRLF & "Please be patient"
            ProgressBar.SetValue Idx, MaxCount
            If UCase(.Name) <> "UNION" Then
                LastCol = RealLastCell(SkillSheet).Column
                If BegCol = 0 Then
                    BegCol = InColNum(.Cells(HeaderRow - 1, 1), "Regular", LastCol)
                    EmpCol = InColNum(.Cells(HeaderRow, 1), "Employee", LastCol)
                    SSNCol = InColNum(.Cells(HeaderRow, 1), "SSN", LastCol)
                    Col401K = InColNum(.Cells(HeaderRow, 1), "401(K)", LastCol)
                End If


                'Set Underline on Top Header
                Set fRange = .Range(.Cells(TopDataRow - 2, EmpCol), .Cells(TopDataRow - 2, LastCol))
                With fRange.Borders(xlBottom)
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                End With
    
                'set Totals Underline
                LastRow = RealLastCell(SkillSheet).Row - 2
                Set fRange = .Range(.Cells(LastRow, BegCol), .Cells(LastRow, LastCol))
                With fRange.Borders(xlBottom)
                    .LineStyle = xlDouble
                    .ColorIndex = xlAutomatic
                End With
    
                'Set Autofit to columns
                With SkillSheet
                    .Range(.Cells(1, 1), .Cells(1, LastCol)).EntireColumn.AutoFit
                    With .Columns(SSNCol)
                        .ColumnWidth = .ColumnWidth + 1.5
                    End With
                End With
                'Set SheetColumns width
                Set fRange = .Range(.Cells(1, BegCol), .Cells(1, LastCol))
                fRange.ColumnWidth = 12
    
                'set print area
                LastRow = RealLastCell(SkillSheet).Row
                Set fRange = .Range(.Cells(TopDataRow, 1), SkillSheet.Cells(LastRow, LastCol))
                With .PageSetup
                    .PrintArea = fRange.Address
                    .PrintTitleRows = "1:" & TopDataRow - 2
                End With
                'set PageSetup
                With .PageSetup
                    .LeftHeader = LftHeader
                    .CenterHeader = ""
                    .RightHeader = RhtHeader
                    .LeftFooter = ""
                    .CenterFooter = "Page &P"
                    .RightFooter = ""
                    .Zoom = False
                    .FitToPagesWide = 1
                    .FitToPagesTall = 8
                    .PrintGridlines = False
                    .LeftMargin = Application.InchesToPoints(0)
                    .RightMargin = Application.InchesToPoints(0)
                    .TopMargin = Application.InchesToPoints(1)
                    .BottomMargin = Application.InchesToPoints(1)
                    .HeaderMargin = Application.InchesToPoints(0.25)
                    .FooterMargin = Application.InchesToPoints(0.5)
                    .Orientation = xlLandscape
                    .PaperSize = xlPaperLegal
                End With
            End If
            .Select
            .Cells(TopDataRow, SSNCol).Select
            Windows(UnionBook.Name).FreezePanes = True
            'Hide the 401k deductions columns,accounts for the local columns (3)
            .Range(.Cells(1, Col401K), .Cells(1, Col401K + 2)).EntireColumn.Hidden = True
        End With
    Next SkillSheet
    ProgressBar.Clear
    UnionBook.Worksheets(1).Select
    
    Windows(UnionBook.Name).Visible = True
    
    Set fRange = Nothing
    Set SkillSheet = Nothing
End Sub

 

[Jay Petrulis]

Hi,

With 20 worksheets to cycle through my guess is that the .PageSetup actions for each sheet is what is slowing the routine.

Check the following thread...
http://mrexcel.com/board/viewtopic.php?topic=19598&forum=2

...for Damon's excellent description of the problem. Also, check my post to the thread detailing one workaround using Excel 4.0 macro functions. That has helped me a lot.

Barring that, you can always use the usual suspects -- screen updating to false, calculation to manual, although those probably won't make much impact here.

 

[Ivan F Moala]

Just to Add to Jays response


Don't display pagebreaks
eg .DisplayPageBreaks = False

There is another method just as fast as
the ExecuteExcel4Macro Method but go with
Jays suggestion...

 

[XL Pro]

Thanks for the replies it has helped.

I don't suppose anyone has written a wrapper function or class for the PAGE.SETUP function?