'supprimer les formats cellules personnalisés code d'origine Laurent Longre
'fonctionne jusque Excel 2007 avec la référence "Microsoft Forms 2.0 Object Library"
'si réfce inexistante, faire parcourir... et sélectionner \WINDOWS\system32\FM20.DLL
'.. sinon vous créez un userform et vous le supprimez, la réfce sera cochée automatiquement
'------------------------------
'VOIR explication pour la ligne If Not IsEmpty(Cell) Or True Then '***) mettre False ou True selon !?
'------------------------------
Private Sub SupprFormatCellPerso()
On Error GoTo Erreur: Err.Clear
Dim DatObj As New DataObject, CollectFormat As New Collection
Dim Wksht As Worksheet, Shts As Sheets, Cell As Range
'test si des feuilles sont protégées (erreur avec Application.Dialogs..)
For Each Wksht In Worksheets
If Wksht.ProtectContents = True Then
Msg$ = "Pour exécuter cette macro, aucune feuille ne doit être protégée." & vbLf & vbLf & _
"La feuille " & Wksht.Name & " doit être déprotégée !"
MsgBox Msg$, vbInformation: Exit Sub
End If
Next
'svg feuil select en cours pour replacer à la fin
Set Shts = ActiveWindow.SelectedSheets
Application.ScreenUpdating = False
'1' Collecte des formats en cours...
' init touches clavier pour copier les formats dans le presse papier
' ouvre la boite de dialogue des formats
' load formats dans le presse papier et ajoute à la collection
MsgBox "Je vais loader les formats ..."
'F% = 0: I% = 0 Application.SendKeys de Laurent Longre
'Do: F% = (F% + 1) Mod 5: If F% = 0 Then I% = I% + 1
'Application.SendKeys "{TAB}{END}{TAB 2}{HOME}" & IIf(I%, "{PGDN " & I% & "}", "") & IIf(F%, "{DOWN " & F% & "}", "") & "+{TAB}^c{ESC}"
' modif perso simplifié
'Application.SendKeys pour se placer dans la boite de dialogue des formats cellules...
'{TAB}sur Catégorie {END}sur Personnalisés {TAB 2}sur la liste des formats {HOME}en haut
'{DOWN F%}curseur bas autant de fois dans la liste
'+{TAB}MajusTab(soit Tab arrière)remonte au-dessus case Type: (pour après copier les caract)
'^c Copie dans PressPap {ESC}sortie
SvgForma$ = "": F% = 0 'départ après Standard
Do: F% = F% + 1
Application.SendKeys "{TAB}{END}{TAB 2}{HOME}{DOWN " & F% & "}" & "+{TAB}^c{ESC}"
Application.Dialogs(xlDialogFormatNumber).Show: DatObj.GetFromClipboard
Forma$ = DatObj.GetText(1): If Forma$ = SvgForma$ Then Exit Do
CollectFormat.Add Forma$, Forma$: SvgForma$ = Forma$
Loop
'2' Recherche des formats utilisés en cours (boucle sur toutes les feuil)
'ligne If Not IsEmpty(Cell) Or ???? Then *** mettre False ou True selon..
'***) Or True pour supprimer les formats inutilisés dans les cellules .
'***) Or False pour supprimer les formats dans les cellules vides .
'IsEmpty(Cell)=True si non initialisé / donc Not True=False si initialisé
'test Ok: si False Ou False / si False Ou True
MsgBox "Je vais tester les formats ..."
On Error Resume Next: Err.Clear: Z$ = ""
'boucle sur toutes les feuil
For Each Wksht In Worksheets
Wksht.Select 'boucle cells de la feuil
For Each Cell In Wksht.UsedRange
If Not IsEmpty(Cell) Or True Then '***) mettre False ou True selon !?
Z$ = CollectFormat.Item(Cell.NumberFormatLocal) 'si format existe on le garde
If Z$ <> "" Then CollectFormat.Remove Cell.NumberFormatLocal: Z$ = "" 'enlève de la liste à supprimer
End If
Next
Next
'3' CreNouv classeur pour coller et tester/supprimer formats personnalisés
MsgBox "Je vais supprimer les formats ..."
On Error Resume Next: Err.Clear: F% = 0
With ActiveWorkbook
Workbooks.Add
For I% = 0 To CollectFormat.Count
Range("A1").NumberFormatLocal = CollectFormat(I%) 'colle le format
.DeleteNumberFormat ActiveCell.NumberFormat 'delete format (de ActiveCell ! pas pareil que CollectFormat(I%)
If Err Then Err.Clear Else F% = F% + 1 'si Err ce n'est pas un perso
Next
End With
ActiveWorkbook.Close False
'fin
Shts.Select
Application.ScreenUpdating = True
MsgBox F% & " format(s) inutilisé(s) supprimé(s).", vbInformation
Set DatObj = Nothing: Set CollectFormat = Nothing: Set Wksht = Nothing: Set Shts = Nothing
On Error GoTo 0: Err.Clear
Exit Sub
Erreur: '-- traite erreur -------
Application.ScreenUpdating = True
Msg$ = "Erreur " & Err.Source & " No " & Err.Number & vbLf & vbLf & Err.Description
MsgBox Msg$, vbCritical, "", Err.HelpFile, Err.HelpContext
On Error GoTo 0: Err.Clear
End Sub
