Speed up VBA formatting on 100+ worksheets

[KTK8]

Firstly, Hello! I've used this forum for many years as a useful tool when trying to find solutions to automate many of my work tasks over the years. I've never needed to post a question as I've always found a solution already on the forum. Thank you for all the help over the years!

I was wondering if someone could review the code I'm currently using to see if there is a way to speed up the process. When I pull my invoices from D365 to excel, there are formatting changes I need to do before I can print and it needs to loop through every worksheet in the workbook. Depending on the amount of orders for a specific customer there can be 100-250 worksheets that need to be formatted before printing.

Sub Invoice1SetUp()
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Sheets
    ws.Select
        Call xruncode
    Next
    Application.ScreenUpdating = True
End Sub
Private Sub xruncode()
'
' Macro1 Macro
'

'
    Range("G15:J16").Select
    Selection.VerticalAlignment = xlBottom
    Range("Y1:AD1").Select
    Selection.ClearContents
    Application.PrintCommunication = True
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .RightHeader = "Page &P of &N"
        .LeftMargin = Application.InchesToPoints(0.2)
        .RightMargin = Application.InchesToPoints(0.2)
        .TopMargin = Application.InchesToPoints(0.2)
        .BottomMargin = Application.InchesToPoints(0.2)
        .HeaderMargin = Application.InchesToPoints(0.2)
        .FooterMargin = Application.InchesToPoints(0.2)
        .Orientation = xlPortrait
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintTitleRows = "$1:$22"
  
    Dim r As Range

  For Each r In ActiveSheet.UsedRange

    Dim length As Integer
    length = Len(r.Value)
    If length >= 57 Then
        r.RowHeight = 25.75
    Rows("12:12").RowHeight = 51
    Rows("20:20").RowHeight = 23
    End If

  Next r

End With
End Sub

Thank you for your time.

 

[Joe4]

Welcome to the Board!

Note that I think this line is looping through every single cell in your Used Range, not just one cell per row:

        For Each r In ActiveSheet.UsedRange

Is that what you really want to do?
Or do you just want to look through a certain column?
Looping through every single cell unnecessarily could certainly affect performance.

 

[FormR]

Hi, welcome to posting!

Assuming that it is necessary for you to check all the cells in the used range, here's one way you could try that does that part in memory, and also cutting short the search for each row when you identify the first value in that row that meets the criteria.

Sub Invoice1SetUp()
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Sheets
        Call xruncode(ws)
    Next
    Application.ScreenUpdating = True
End Sub

Private Sub xruncode(ws As Worksheet)
  
    Dim length As Integer
    Dim v As Variant, i As Long, j As Long, r As Range
  
    With ws
      
        .Range("G15:J16").VerticalAlignment = xlBottom
        .Range("Y1:AD1").ClearContents
      
        Application.PrintCommunication = False
        With .PageSetup
            .RightHeader = "Page &P of &N"
            .LeftMargin = Application.InchesToPoints(0.2)
            .RightMargin = Application.InchesToPoints(0.2)
            .TopMargin = Application.InchesToPoints(0.2)
            .BottomMargin = Application.InchesToPoints(0.2)
            .HeaderMargin = Application.InchesToPoints(0.2)
            .FooterMargin = Application.InchesToPoints(0.2)
            .Orientation = xlPortrait
            .PaperSize = xlPaperLetter
            .FirstPageNumber = xlAutomatic
            .FitToPagesWide = 1
            .FitToPagesTall = False
            .PrintTitleRows = "$1:$22"
        End With
        Application.PrintCommunication = True
    
        v = .UsedRange.Value
        
        For i = 1 To UBound(v, 1)
            For j = 1 To UBound(v, 2)
                If Len(v(i, j)) >= 57 Then
                    If Not r Is Nothing Then
                        Set r = Union(r, .Rows(i))
                    Else
                        Set r = .Rows(i)
                    End If
                    Exit For
                End If
            Next j
        Next i
  
        r.RowHeight = 25.75
        .Rows("12:12").RowHeight = 51
        .Rows("20:20").RowHeight = 23
      
    End With

End Sub

 

[KTK8]

the cells that I need to adjust row height if characters are more than 57 is a merged cell. My company loves to format reports to have merged cells....
P-W starting with row 23.

 

[FormR]

is a merged cell

Oh, a very important consideration and a point that means I'll need to step away from the thread due to personal time constraints - sorry.

 

[KTK8]

Oh, a very important consideration and a point that means I'll need to step away from the thread due to personal time constraints - sorry.

I understand and feel the same way towards merged cells. Thank you, and I hope you have a great day.

 

[FormR]

Out of interest - did you try the code as posted?

+ Edit - are the columns merged across a single row, or do you have rows merged too?

 

[KTK8]

Out of interest - did you try the code as posted?

+ Edit - are the columns merged across a single row, or do you have rows merged too?

it is merged across a single row.

This is the error when I tried your code above.

 

[FormR]

This is the error when I tried your code above.

Which line of code is highlighted when you click "Debug"?

 

[KTK8]

.Range("Y1:AD1").ClearContents

When I replaced it with what I originally had, and kept the remainder as you posted, it works, but only for the first worksheet.

Range("G15:J16").Select
Selection.VerticalAlignment = xlBottom
Range("Y1:AD1").Select
Selection.ClearContents