Microsoft 365 Affichage lignes masquées - temps de traitement

Sub SupprFormatsInutilisés()
  SupprFormats True
End Sub

Sub SupprFormatsCellulesVides()
  SupprFormats False
End Sub

Sub SupprFormats(Min As Boolean)

  Dim Form As String, Prev As String, F As String
  Dim I As Integer, J As Integer
  Dim C As New Collection
  Dim Wksht As Worksheet, Cell As Range, Shts As Sheets
 
  Application.EnableCancelKey = xlDisabled
  Application.StatusBar = "Collecte des formats en cours..."
  Do
    J = (J + 1) Mod 5
    If J = 0 Then I = I + 1
    Application.SendKeys "{TAB}{END}{TAB 2}{HOME}" & IIf(I, "{PGDN " _
      & I & "}", "") & IIf(J, "{DOWN " & J & "}", "") & "+{TAB}^c{ESC}"
    Application.Dialogs(xlDialogFormatNumber).Show
    
    C.Add Form, Form
    Prev = Form
  Loop
  Application.StatusBar = "Recherche des formats utilisés en cours..."
  Set Shts = ActiveWindow.SelectedSheets
  On Error Resume Next
  For Each Wksht In Worksheets
    Wksht.Select
    For Each Cell In Wksht.UsedRange
      If Not IsEmpty(Cell) Or Min Then
        F = C.Item(Cell.NumberFormatLocal)
        If F <> "" Then
          C.Remove Cell.NumberFormatLocal
          F = ""
        End If
      End If
    Next Cell
  Next Wksht
  Application.ScreenUpdating = False
  Err.Clear
  Application.StatusBar = False
  J = 0
  With ActiveWorkbook
    Workbooks.Add
    For I = 1 To C.Count
      Range("A1").NumberFormatLocal = C(I)
      .DeleteNumberFormat ActiveCell.NumberFormat
      If Err = 0 Then J = J + 1 Else Err.Clear
    Next I
    MsgBox J & " format(s) inutilisé(s) supprimé(s).", vbInformation
  End With
  ActiveWorkbook.Close False
  Shts.Select

End Sub

' réinitialise l'emplacement de la dernière cellule
 Sub RéinitUsedRange()
ActiveSheet.UsedRange
 End Sub
'Et pour faire une cure contrex :
Sub NettoieEtDerniereCellule()     ' Laurent Longre
  Dim Sht As Worksheet, DCell As Range, Calc As Long, Rien As String
  On Error Resume Next
  Calc = Application.Calculation
  With Application
    .Calculation = xlCalculationManual
    .StatusBar = "Nettoyage en cours..."
    .EnableCancelKey = xlErrorHandler
    .ScreenUpdating = False
  End With
  For Each Sht In Worksheets
    If Sht.UsedRange.Address <> "$A$1" Or Not IsEmpty(Sht.[A1]) Then
      Set DCell = Sht.Cells.Find("*", , , , xlByRows, xlPrevious)(2)
      If Not DCell Is Nothing Then
        Sht.Range(DCell, Sht.Cells([A:A].Count, 1)).EntireRow.Clear
        Set DCell = Nothing
        Set DCell = Sht.Cells.Find("*", , , , xlByColumns, xlPrevious)(, 2)
        If Not DCell Is Nothing Then _
          Sht.Range(DCell, Sht.[IV1]).EntireColumn.Clear
      End If
      Rien = Sht.UsedRange.Address
    End If
  Next Sht
  Application.StatusBar = False
  Application.Calculation = Calc
End Sub