VBA code too slow. Ideas for improvement?

[excelstarter1]

Hello,

a couple of weeks ago I wrote a macro to format the title of a table in Excel. A task which I repeat every 20 minutes or so. So far the marco does exactly what I want. However, for some odd reason the execution of the code gets slower and slower by the minute. Maybe the code is flawed in general, unfortunately I am not yet a VBA pro. In the morning the exection of e.g. 10 cells took less than a second. In the evening the execution took 3-4 seconds and you can watch the code working through each cell on the screen.

I created a Ribbon for Excel, so that I have all my macros stored in a toolbar. But I assume that the macro does not interfer with the other macros. There is no link or the like. Each macro/sub runs seperately without interactions.

It would be great if you could take a look at the code and suggest an improvement. Thank you very much in advance!!

Regards

Option Explicit

Sub format_table()
'I run the macro within the Ribbon so the original Sub would be: Sub format_table(control As IRibbonControl)
    
On Error GoTo ErrorHandler
    
    Application.ScreenUpdating = False
    
    Dim cell As Range
    Dim selec As Range
    Dim numbr As Integer
    
    Set selec = Selection
    
    numbr = selec.Columns.Count
    
        With selec
            .ClearFormats
            .Interior.Pattern = xlSolid
            .Interior.PatternColorIndex = xlAutomatic
            .Interior.Color = rgb(100, 100, 100)
            .Font.Bold = True
            .Font.Italic = False
            .Font.Name = "Arial"
            .Font.Size = 12
            .Font.Color = rgb(200, 200, 200)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .RowHeight = 12.75
        End With
    
    If Not IsNumeric(selec.Columns(1)) Then
        selec.Columns(1).HorizontalAlignment = xlRight
        'if cell is text in first column of selected area than move right
    Else
    End If
    
    numbr = selec.Columns.Count
    
    If numbr = 1 Then
        selec.HorizontalAlignment = xlRight
        'special case, if only one column selected than move content of selected area right
    End If
           
    Application.ScreenUpdating = True
    
Exit Sub
    
ErrorHandler:

    Debug.Print "Error: " & Err.number & " " & Err.Description
    Err.Clear
    Resume Next
    
End Sub

 

[JackDanIce]

Not sure why you're experiencing a slowing execution time, not much to optimise in the code, but try:

Option Explicit

Sub Format_Table()

    On Error GoTo ErrorHandler
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    With Selection
        .ClearFormats
        .Interior.Pattern = xlSolid
        .Interior.PatternColorIndex = xlAutomatic
        .Interior.Color = RGB(100, 100, 100)
        .Font.Bold = True
        .Font.Italic = False
        .Font.Name = "Arial"
        .Font.Size = 12
        .Font.Color = RGB(200, 200, 200)
        .HorizontalAlignment = IIf(.Columns.Count > 1, xlCenter, xlRight)
        .VerticalAlignment = xlCenter
        .RowHeight = 12.75
        If IsNumeric(.Columns(1)) Then .Columns(1).HorizontalAlignment = xlRight
    End With
                
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
    Exit Sub

ErrorHandler:
    Debug.Print "Error: " & err.Number & " " & err.Description
    err.Clear
    Resume Next

End Sub

 

[excelstarter1]

Great, thank you very much for your suggestions.
I will try it out immediately!

 

[excelstarter1]

Similarly, I have another code to format tables, which I assume slows down the execution. It would be awesome if you could have a look with regard to the performance/execution time. I believe loops are not the best option...

Basically the macro checks the table for text and values/formulas. If I have text I want it on the left. Numbers and formulas should remain on the right:

Option Explicit

Sub format_table2()

    On Error GoTo ErrorHandler
    
    Dim c as Range 'cell

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    With Selection
        .HorizontalAlignment = xlRight
    End With

    If Selection.CountLarge = 1 Then
        If Not Selection.HasFormula And Len(Selection.Formula) <> 0 And Not IsNumeric(Selection.Formula) Then
            Selection.HorizontalAlignment = xlLeft
        End If
    Else
        For Each c In Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
            c.HorizontalAlignment = xlLeft
        Next c
    End If
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    
    Exit Sub

ErrorHandler:
    Debug.Print "Error: " & err.Number & " " & err.Description
    err.Clear
    Resume Next

End Sub

 

[JackDanIce]

Try:

Sub Format_Table2()


    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With


    With Selection
        .HorizontalAlignment = xlRight
        .SpecialCells(xlCellTypeConstants, xlTextValues).HorizontalAlignment = xlLeft
    End With


    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With


End Sub

 

[excelstarter1]

Great!! Thanks!

The only issue is that when only ONE cell is selected ALL SpecialCells are formatted left. Thats what I do not want and therefore I used the statement. Any idea how to implement that as well?

If Selection.CountLarge = 1 Then

 

[JackDanIce]

Try:

Sub Format_Table2()

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    With Selection
        If .Count = 1 And Not .HasFormula And Not IsNumeric(.Value) Then
            .HorizontalAlignment = xlLeft
        Else
            .HorizontalAlignment = xlRight
            .SpecialCells(xlCellTypeConstants, xlTextValues).HorizontalAlignment = xlLeft
        End If
    End With

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

 

[excelstarter1]

Awesome, thank you so much for your work and quick help! Much appreciated!

 

[JackDanIce]

You're welcome

 

[excelstarter1]

Sorry to bother you again...
I just tested the code. When I select a single cell with a value/number, ALL SpecialCells with Text move to the left. How would I get rid of the issue?