Microsoft 365 filtrages temps exécution très long

Sub Filtrer(critere As Range)
Trie_Ttlignes
[6:6].AutoFilter
[6:6].AutoFilter Field:=24, Criteria1:=[E3] 'Field:=1 colonne filtrage
[X1] = "=""Affiché""&""                          ""&SUBTOTAL(103,R[6]C:R[99999]C)"
[V1] = "=IF(R5C35>0,R5C35,""O"")"
[AA5] = "=COUNTIF(C[-3],""" & critere & """)"
lig = 0
VisibleRangeFormat
End Sub

Sub VisibleRangeFormat()
Dim col%, P As Range
If ActiveWindow.ScrollRow <> lig And ActiveWorkbook.Name = ThisWorkbook.Name And UCase(ActiveSheet.Name) = "SUIVISAPPELS" Then
    lig = ActiveWindow.ScrollRow
    Application.ScreenUpdating = False
    ActiveSheet.Protect Password:="", UserInterfaceOnly:=True
    Rows("7:100000").ClearFormats 'RAZ
    Set P = Intersect(ActiveWindow.VisibleRange.EntireRow, Range("A7:A100000")).SpecialCells(xlCellTypeVisible).EntireRow
    For col = 1 To 29
        With Intersect(Columns(col), P)
            If col < 27 Then .Borders.Weight = xlHairline: .VerticalAlignment = xlCenter
            Select Case col
                Case 2: .VerticalAlignment = xlTop: .Orientation = xlVertical
                Case 5, 20, 22: .NumberFormat = "dd mm yyyy hh:mm": .WrapText = True: .ShrinkToFit = True: .HorizontalAlignment = xlCenter
                Case 19, 24: .WrapText = True
                Case 29: .Interior.Color = 15592941 'gris clair
            End Select
        End With
    Next
End If
On Error Resume Next
Application.OnTime t, "VisibleRangeFormat", , False
t = Now + 1 / 86400 'temporisation 1 seconde
Application.OnTime t, "VisibleRangeFormat"
End Sub

Private Sub Workbook_Open()
VisibleRangeFormat 'lance la macro et le processus
Me.Saved = True 'évite l'invite à la fermeture si aucunemodification
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime t, "VisibleRangeFormat", , False 'évite la relance du processus
End Sub