optimise reformatting macro

[ajm]

hi all, i have the following macro that goes to particular sheets in the active workbook, creates a table if there is something on the tab, and reformats the columns. Each tab is different.

Sub TPDCleanseData()
'
' TPDCleanseData Macro
'

    With ActiveWorkbook
        Cells.Replace What:="null", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

  
        With Sheets("Summary")
            If .Range("a6") = "" Then GoTo One
                Set target = .Range("a6:AA6", .Range("A" & .Rows.Count).End(xlUp))
                .ListObjects.Add(xlSrcRange, target, , xlNo, "TableStyleMedium2").Name = _
                 "tblSumm"

                
                .Range("tblSumm[[Column1]:[Column1]]").NumberFormat = "0"
                .Range("tblSumm[[Column3]:[Column3]]").NumberFormat = "0"
                .Range("tblSumm[[Column15]:[Column17]]").NumberFormat = "0"
                .Range("tblSumm[[Column23]:[Column24]]").NumberFormat = "0"
                .Range("tblSumm[[Column4]:[Column14]]").Style = "Currency"
                .Range("tblSumm[[Column4]:[Column14]]").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Range("tblSumm[[Column18]:[Column22]]").Style = "Currency"
                .Range("tblSumm[[Column18]:[Column22]]").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Range("tblSumm[[Column25]:[Column27]]").Style = "Currency"
                .Range("tblSumm[[Column25]:[Column27]]").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Columns("I:I").ColumnWidth = 17
                .Tab.ColorIndex = 43
One:
           'End If
           
        End With
   
        With Sheets("BAS")
            If .Range("a1") = "" Then GoTo Two
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblBAS"
                .Range("A:b,D:D,f:f,m:m,r:r,x:z,ab:ab,AD:AD").NumberFormat = "0"
                .Range("S:W").Style = "Currency"
                .Range("S:W").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Two:
            'End If
        End With
  
        With Sheets("ITR")
            If .Range("a1") = "" Then GoTo Three
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblITR"
                .Range("A:A,C:C,D:D,S:T,AA:AB,AE:AE,av:av").NumberFormat = "0"
                .Range("U:Z, AG:AG, AN:AU, AZ:BA").Style = "Currency"
                .Range("U:Z, AG:AG, AN:AU, AZ:BA").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Range("Ax:AY").NumberFormat = "m/d/yyyy"
                .Range("BH:BH").NumberFormat = "m/d/yyyy"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Three:
            'End If
        End With
  
        With Sheets("PAYG")
            If .Range("a1") = "" Then GoTo Four
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblPAYG"
                .Range("A:A,H:H,M:N").NumberFormat = "0"
                .Range("J:L, O:S").Style = "Currency"
                .Range("J:L,O:S").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Four:
            'End If
        End With
    
        With Sheets("FBT")
            If .Range("a1") = "" Then GoTo Five
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblFBT"
                .Range("A:A,g:g,l:l,R:R,X:X,Z:AA").NumberFormat = "0"
                .Range("S:W, Y:Y").Style = "Currency"
                .Range("S:W, Y:Y").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Five:
            'End If
        End With
    
        With Sheets("EMP_CNT")
            If .Range("a1") = "" Then GoTo Six
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblEmpCnt"
                .Range("A:B,E:F").NumberFormat = "0"
                .Range("D:D").Style = "Currency"
                .Range("D:D").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Six:
            'End If
        End With
    
        With Sheets("Workcover")
            If .Range("a1") = "" Then GoTo Seven
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblWkCover"
                .Range("A:B,G:G,P:P,Z:Z").NumberFormat = "0"
                .Range("E:F,U:Y").NumberFormat = "m/d/yyyy"
                .Range("I:L").Style = "Currency"
                .Range("I:L").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Seven:
            'End If
        End With
    
        With Sheets("DETE")
            If .Range("a1") = "" Then GoTo Eight
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblDETE"
                .Range("A:a,c:c,E:E,M:N,R:R,Z:Z,AD:AE,AL:AL,AP:AP").NumberFormat = "0"
                .Range("F:H,AR:AR").NumberFormat = "m/d/yyyy"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Eight:
            'End If
        End With
    
        With Sheets("BAS Benef")
            If .Range("a1") = "" Then GoTo Nine
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblBasBen"
                .Range("a:b,F:G").NumberFormat = "0"
                .Range("H:H").Style = "Currency"
                .Range("H:H").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Range("m:m").NumberFormat = "m/d/yyyy"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Nine:
            'End If
        End With
    
    
        With Sheets("TPAR")
            If .Range("a1") = "" Then GoTo Ten
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblTPAR"
                .Range("A:C,E:E,G:G,Q:R,V:V").NumberFormat = "0"
                .Range("S:U").Style = "Currency"
                .Range("S:U").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Ten:
            'End If
        End With
        
        With Sheets("ESS")
            If .Range("a1") = "" Then GoTo Eleven
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblESS"
                .Range("a:c,E:G,I:I,K:K,T:T,X:Y,AA:AC").NumberFormat = "0"
                .Range("H:H, J:J, L:M").Style = "Currency"
                .Range("H:H, J:J, L:M").NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Eleven:
            'End If
        End With
    
        Sheets("Caveat").Activate
        Range("B30").Select
    
    End With
End Sub

 

[Alex Blakenburg]

Your heading indicates you think the formatting is slowing the macro down.
My initial thoughts were that since you are formatting whole columns instead of just the table range, it might be the cause of the macro being slow but its running in seconds on my machine. (Admittedly with very little data but if the issue is whole column that shouldn't matter)

How are experiencing the slow speed ?
Is current region on any of the sheets picking up a much bigger range than you are expecting ?
Do the sheets have a lot of formulas in them ?

If you did want to restrict the formatting to just the Data Range changing your code to the following should work but I am not sure it will make much difference in terms of speed.

        Dim rngTbl As Range                     ' Added this
  
        With Sheets("BAS")
            If .Range("a1") = "" Then GoTo Two
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = "TblBAS"
                
                Set rngTbl = Range("TblBAS")     ' Added this & Intersect in the following
                Intersect(rngTbl, _
                    .Range("A:b,D:D,f:f,m:m,r:r,x:z,ab:ab,AD:AD")).NumberFormat = "0"
                Intersect(rngTbl, _
                    .Range("S:W")).Style = "Currency"
                Intersect(rngTbl, _
                    .Range("S:W")).NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
Two:
            'End If
        End With

Have you tried adding the following to the beginning and end of your code

Beginning

    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

End

    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

 

[ajm]

Hi Alex, Thanks for the response. Actually, the speed is not an issue as far as i can tell. I just don't like writing messy macros and thought if there was a better way to do what i am doing, other excellers would be sure to tell me. As you rightly suggest, I forgot to turn everything off and then on again which i will add this morning. I like your way of limiting the focus to only the tables by using intersect. I haven't used it much. As far as i can tell, the current range on each sheet is only the tables and these are not large generally; maybe 200 or 300 rows at the largest. And its all static data with no formulas at all.

 

[Alex Blakenburg]

There are far better coders on the forum than I am, so hopefully you will get some more input.
You obviously changed your mind on the If statement and went with a goto.
I found the goto a bit confusing but that was also partly due indentation still being based on your original version of the if statement.

Particular since the code is being copied and pasted several times, I would have thought it would be easier to pull out the things you need to change every time you copy & paste it (sheet name and table name). That also heads you in the direction of making the common code into a function.
(Dim statements apply to all and need to go right at the top of the module)

        Dim rngTbl As Range
        Dim rngFormat As Range
        Dim TblName As String
        Dim ShtName As String
        
        ShtName = "BAS"
        TblName = "TblBAS"
        
        With Sheets(ShtName)
            If .Range("a1") <> "" Then
                .ListObjects.Add(SourceType:=xlSrcRange, Source:=.Cells(1).CurrentRegion, _
                XlListObjectHasHeaders:=xlYes, TableStyleName:="TableStyleMedium2").Name = TblName
                
                Set rngTbl = Range(TblName)
                Intersect(rngTbl, _
                    .Range("A:b,D:D,f:f,m:m,r:r,x:z,ab:ab,AD:AD")).NumberFormat = "0"
                Intersect(rngTbl, _
                    .Range("S:W")).Style = "Currency"
                Intersect(rngTbl, _
                    .Range("S:W")).NumberFormat = "_-$* #,##0_-;-$* #,##0_-;_-$* ""-""??_-;_-@_-"
                .Cells.EntireColumn.AutoFit
                .Tab.ColorIndex = 43
            End If
        End With