Is there a way to speed up formatting thousands of lines?-CodePudding

I have made the following code which removes the need for a for loop but it still freezes up Excel. This code essentially will format 8 rows a specific way with borders, number formats, etc. I need to speed this up as I am running this alongside another macro I wrote that works in a reasonable amount of time but adding this formatting messes with something.

Sub Format()
'Borders
Range("A2:F9,G2:I3,G4:I5,G6:I7,G8:I9,J2:V3,J4:V5,J6:V7,J8:V9,W2:W9,X2:AI3,X4:AI5,X6:AI7,X8:AI9,AJ2:AJ9").Select
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With

'Format percentages
Range("X3:AI3,X5:AI5,X7:AI7,X9:AI9").Select
Selection.NumberFormat = "0.00%"

Range("F:F,J2:W" & endRow).Select
Selection.NumberFormat = "0"

Range("J1:V1").Select
Selection.NumberFormat = "mmm-yy"

Range("X1:AI1").Select
Selection.NumberFormat = "mmm"

'Text Alignment
Range("A:A,C:C,D:D,F:AJ").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .ReadingOrder = xlContext
End With

Range("A2:AJ9").Copy
Range("A2:AJ" & endRow).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

Range("A1,C1,D1,F1:I1,W1,AJ1").EntireColumn.AutoFit
Range("B1").ColumnWidth = 32
Range("E1").ColumnWidth = 40
Range("J1:V1,X1:AI1").ColumnWidth = 7.5
End Sub

The variable endRow is determined elsewhere as this macro is called inside of another. For simplicity let's assume the endRow = 80,002 (The extra 2 accounts for the headers).

Edit 1:

For clarification there is a header row and then the data to be formatted is below. A few lines of this code modifies the header data so the following is the code without the headers being formatted for clarity on the problem.

Sub Format()
'Borders
Range("A2:F9,G2:I3,G4:I5,G6:I7,G8:I9,J2:V3,J4:V5,J6:V7,J8:V9,W2:W9,X2:AI3,X4:AI5,X6:AI7,X8:AI9,AJ2:AJ9").Select
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With

'Format percentages
Range("X3:AI3,X5:AI5,X7:AI7,X9:AI9").Select
Selection.NumberFormat = "0.00%"

Range("F:F,J2:W" & endRow).Select
Selection.NumberFormat = "0"

'Text Alignment
Range("A:A,C:C,D:D,F:AJ").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .ReadingOrder = xlContext
End With

Range("A2:AJ9").Copy
Range("A2:AJ" & endRow).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

Range("A1,C1,D1,F1:I1,W1,AJ1").EntireColumn.AutoFit
Range("B1").ColumnWidth = 32
Range("E1").ColumnWidth = 40
Range("J1:V1,X1:AI1").ColumnWidth = 7.5
End Sub

Edit 2:

I tried what Tim Williams suggested but that just causes all cells to have all borders which I do not want.

Edit 3:

This post is getting rather long, but here is what I have come up with that I suspect could be further optimized but I am unsure of as to how that would be accomplished.

Sub Format()
Dim rng As Range
Set rng = Sht.Range("A2:F9,G2:I3,G4:I5,G6:I7,G8:I9,J2:V3,J4:V5,J6:V7,J8:V9,W2:W9,X2:AI3,X4:AI5,X6:AI7,X8:AI9,AJ2:AJ9")
'Borders
With rng.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With rng.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With rng.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With
With rng.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlMedium
End With

'Format percentages
Range("X3:AI3,X5:AI5,X7:AI7,X9:AI9").NumberFormat = "0.00%"

Range("F:F,J2:W" & endRow).NumberFormat = "0"

Range("J1:V1").NumberFormat = "mmm-yy"

Range("X1:AI1").NumberFormat = "mmm"

'Text Alignment
With Range("A:A,C:C,D:D,F:AJ")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .ReadingOrder = xlContext
End With

Range("A2:AJ9").Copy
Range("A2:AJ" & endRow).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Range("A1,C1,D1,F1:I1,W1,AJ1").EntireColumn.AutoFit
Range("B1").ColumnWidth = 32
Range("E1").ColumnWidth = 40
Range("J1:V1,X1:AI1").ColumnWidth = 7.5
End Sub

CodePudding user response：

Format Thousands of Lines

Sub Format()
    
    Const EndRow As Long = 80001
    
    Application.ScreenUpdating = False
    
    With ActiveSheet ' improve!
        
        ' Borders
        With .Range("A2:F9,G2:I3,G4:I5,G6:I7,G8:I9,J2:V3,J4:V5," _
                & "J6:V7,J8:V9,W2:W9,X2:AI3,X4:AI5,X6:AI7,X8:AI9,AJ2:AJ9")
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        End With
        
        ' Number Formats
        .Range("X3:AI3,X5:AI5,X7:AI7,X9:AI9").NumberFormat = "0.00%"
        .Range("F1:F9,J2:W9").NumberFormat = "0"
        .Range("J1:V1").NumberFormat = "mmm-yy"
        .Range("X1:AI1").NumberFormat = "mmm"
    
        ' Text Alignment
        With .Range("A1:A9,C1:C9,D1:D9,F1:AJ9")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .ReadingOrder = xlContext
        End With
        
        ' Copy Down Formats
        .Range("A2:AJ9").Copy
        .Range("A2:AJ" & EndRow).PasteSpecial Paste:=xlPasteFormats
        
        ' Column Widths
        .Range("A1,C1,D1,F1:I1,W1,AJ1").EntireColumn.AutoFit
        .Range("B1").ColumnWidth = 32
        .Range("E1").ColumnWidth = 40
        .Range("J1:V1,X1:AI1").ColumnWidth = 7.5
    
    End With
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub

Argumented

Rewrite the previous sub by adding the worksheet argument.

Sub FormatSheet(ByVal ws As Worksheet)

    Const EndRow As Long = 80001

    Application.ScreenUpdating = False

    With ws
    

    End With

    Application.CutCopyMode = False
    Application.ScreenUpdating = True

End Sub

Finally, call the sub from another sub.

Sub Test()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    FormatSheet ws

End Sub

Similarly, you could add the EndRow argument...

Sub FormatSheet2(ByVal ws As Worksheet, ByVal EndRow As Long)

End Sub

and call it with e.g.:

FormatSheet2 ws, 80001

CodePudding user response：

create 2 new class modules and call them by whatever name you want, just for the sake of explanation let's call them SettingClass1 and SettingClass2.

On SettingClass1 write the following code:

Option Explicit

Private calculation As XlCalculation
Private displayStatus As Boolean
Private enableEvents As Boolean
Private screenUpdating As Boolean

Public Sub Backup()

calculation = Application.calculation
displayStatus = Application.DisplayStatusBar
enableEvents = Application.enableEvents
screenUpdating = Application.screenUpdating

End Sub

Public Sub Restore()

Application.calculation = calculation
Application.DisplayStatusBar = displayStatus
Application.enableEvents = enableEvents
Application.screenUpdating = screenUpdating
 
End Sub

Public Sub TurnOff()

Call Backup

Application.calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.enableEvents = False
Application.screenUpdating = False

End Sub

Public Sub TurnOn()

Application.calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.enableEvents = True
Application.screenUpdating = True

End Sub

After that on SettingClass2 write the following code:

Option Explicit

Private Interactive As Boolean
Private DisplayAlerts As Boolean
Private AskUpdateLinks As Boolean

Public Sub Backup()

Interactive = Application.Interactive
DisplayAlerts = Application.DisplayAlerts
AskUpdateLinks = Application.AskToUpdateLinks

End Sub

Public Sub Restore()

Application.Interactive = Interactive
Application.DisplayAlerts = DisplayAlerts
Application.AskToUpdateLinks = AskUpdateLinks
 
End Sub

Public Sub TurnOff()

Call Backup

Application.Interactive = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False

End Sub

Public Sub TurnOn()

Application.Interactive = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

End Sub

Afterwards edit your code by adding:

Sub Format()

Dim settings As New SettingClass1
Dim settingsAlerts As New SettingClass2

settings.TurnOff
settingsAlerts.TurnOff

'Borders

Then at the end of your code add:

Range("J1:V1,X1:AI1").ColumnWidth = 7.5

settings.TurnOn
settingsAlerts.TurnOn

End Sub

I have noticed that in your code sht isn't declared or set anywhere, and also endRow.

So I wrote the code by passing sht to the function, however you need to declare and assign a value to endRow.

You can also optimize further your code by changing it like this:

Sub Format(sht As Worksheet)

Dim settings As New SettingClass1
Dim settingsAlerts As New SettingClass2

settings.TurnOff
settingsAlerts.TurnOff

Dim rng As Range
Dim area As Variant
Set rng = sht.Range("A2:F9,G2:I3,G4:I5,G6:I7,G8:I9,J2:V3,J4:V5,J6:V7,J8:V9,W2:W9,X2:AI3,X4:AI5,X6:AI7,X8:AI9,AJ2:AJ9")
'Borders

For Each area In rng.areas
    
    With area
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
    End With

Next area

'Format percentages
With sht
    
    Set rng = .Range("X3:AI3,X5:AI5,X7:AI7,X9:AI9")
    
    For Each area In rng.areas
        
        With area
            
            .NumberFormat = "0.00%"
            
        End With
        
    Next area
    
    Set rng = .Range("F:F,J2:W" & endRow)
    
    For Each area In rng.areas
        
        With area
            
            .NumberFormat = "0"
            
        End With
        
    Next area
    
    
    .Range("J1:V1").NumberFormat = "mmm-yy"
    
    .Range("X1:AI1").NumberFormat = "mmm"
    
    'Text Alignment
    
    Set rng = .Range("A:A,C:C,D:D,F:AJ")
    
    For Each area In rng.areas
        
        With area
            
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .ReadingOrder = xlContext
            
        End With
        
    Next area
    
    .Range("A2:AJ9").Copy
    .Range("A2:AJ" & endRow).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    Set rng = .Range("A1,C1,D1,F1:I1,W1,AJ1")
    
    For Each area In rng.areas
        
        With area
            
            .EntireColumn.AutoFit
            
        End With
        
    Next area
    
    .Range("B1").ColumnWidth = 32
    .Range("E1").ColumnWidth = 40
    
    Set rng = .Range("J1:V1,X1:AI1")
    
    For Each area In rng.areas
        
        With area
            
            .ColumnWidth = 7.5
            
        End With
        
    Next area
    
End With

settings.TurnOn
settingsAlerts.TurnOn

End Sub

Let me know how this works for you.