Bonjour à tous,
Tout d'abord, je sais très bien que ce sujet a été traité nombre de fois. Malheureusement, aucune des solutions proposées ne sont parvenues à apporter une réponse à mon problème.
Je travaille sur Excel 2003, et comme vous l'avez compris, je fais face à une erreur qui me dit en anglais "Too many different cell format".
Au risque de paraitre irrespectueux, ne perdez pas votre temps à me répondre d'aller voir tel ou tel forum Microsoft, qui m'apporterait un utilitaire capable de nettoyer les formats inutilisés au sein de mon fichier, ou qui me dirait d'utiliser moins de format. Il ne s'agit là que d'une réponse sans aucun intérêt.
Clairement, je n'ai pas utilisé les 4000 formats differents au sein de mon fichier, et quand bien même je supprime tous les onglets et n'en laisse qu'un seul, avec une dizaine de cellules remplies, le problème est encore là. Le comble de ce problème, c'est que sur quelques onglets, il m'enverra le message d'erreur qu'à certains niveaux de la feuille excel (lorsque j'essaie d'insérer une ligne au niveau de la ligne 10, il m'enverra le message d'erreur, mais pas lorsque j'essaie au niveau de la ligne 200...).
Bref, vous l'aurez compris, cette erreur me pourrit la vie, et j'essaie de m'en débarasser !!!
Voici une macro que j'ai compilé, et qui fonctionne, mais qui n'efface pas les formats inutilisés. Si quelqu'un pouvait m'aider à l'affiner, je lui en serais grandement reconnaissant !!
Denis
Tout d'abord, je sais très bien que ce sujet a été traité nombre de fois. Malheureusement, aucune des solutions proposées ne sont parvenues à apporter une réponse à mon problème.
Je travaille sur Excel 2003, et comme vous l'avez compris, je fais face à une erreur qui me dit en anglais "Too many different cell format".
Au risque de paraitre irrespectueux, ne perdez pas votre temps à me répondre d'aller voir tel ou tel forum Microsoft, qui m'apporterait un utilitaire capable de nettoyer les formats inutilisés au sein de mon fichier, ou qui me dirait d'utiliser moins de format. Il ne s'agit là que d'une réponse sans aucun intérêt.
Clairement, je n'ai pas utilisé les 4000 formats differents au sein de mon fichier, et quand bien même je supprime tous les onglets et n'en laisse qu'un seul, avec une dizaine de cellules remplies, le problème est encore là. Le comble de ce problème, c'est que sur quelques onglets, il m'enverra le message d'erreur qu'à certains niveaux de la feuille excel (lorsque j'essaie d'insérer une ligne au niveau de la ligne 10, il m'enverra le message d'erreur, mais pas lorsque j'essaie au niveau de la ligne 200...).
Bref, vous l'aurez compris, cette erreur me pourrit la vie, et j'essaie de m'en débarasser !!!
Voici une macro que j'ai compilé, et qui fonctionne, mais qui n'efface pas les formats inutilisés. Si quelqu'un pouvait m'aider à l'affiner, je lui en serais grandement reconnaissant !!
Denis
Code:
Sub DeleteUnusedCustomNumberFormats()
Dim Buffer As Object
Dim Sh As Object
Dim SaveFormat As Variant
Dim fFormat As Variant
Dim nFormat() As Variant
Dim xFormat As Long
Dim Counter As Long
Dim Counter1 As Long
Dim Counter2 As Long
Dim StartRow As Long
Dim EndRow As Long
Dim pPresent As Boolean
Dim NumberOfFormats As Long
Dim Answer
Dim Cell As Object
Dim DataStart As Long
Dim DataEnd As Long
Dim AnswerText As String
Dim ActWorkbookName As String
Dim BufferWorkbookName As String
NumberOfFormats = 4000
StartRow = 3 ' Do not alter this value
EndRow = 65536 ' For Excel 97 and 2000 set EndRow to 65536
ReDim nFormat(0 To NumberOfFormats)
AnswerText = "Do you want to delete unused custom formats from the workbook?"
AnswerText = AnswerText & Chr(10) & "To get a list of used and unused formats only, choose No."
Answer = MsgBox(AnswerText, 259)
If Answer = vbCancel Then GoTo Finito
On Error GoTo Finito
ActWorkbookName = ActiveWorkbook.Name
Workbooks.Add
BufferWorkbookName = ActiveWorkbook.Name
Set Buffer = Workbooks(BufferWorkbookName).ActiveSheet.Range("A3")
nFormat(0) = Buffer.NumberFormatLocal
Buffer.NumberFormat = "@"
Buffer.Value = nFormat(0)
Workbooks(ActWorkbookName).Activate
Counter = 1
Do
SaveFormat = Buffer.Value
DoEvents
SendKeys "{TAB 3}"
For Counter1 = 1 To Counter
SendKeys "{DOWN}"
Next Counter1
SendKeys "+{TAB}{HOME}'{HOME}+{END}^C{TAB 4}{ENTER}"
Application.Dialogs(xlDialogFormatNumber).Show nFormat(0)
ActiveSheet.Paste Destination:=Buffer
Buffer.Value = Mid(Buffer.Value, 2)
nFormat(Counter) = Buffer.Value
Counter = Counter + 1
Loop Until nFormat(Counter - 1) = SaveFormat
ReDim Preserve nFormat(0 To Counter - 2)
Workbooks(BufferWorkbookName).Activate
Range("A1").Value = "Custom formats"
Range("B1").Value = "Formats used in workbook"
Range("C1").Value = "Formats not used"
Range("A1:C1").Font.Bold = True
For Counter = 0 To UBound(nFormat)
Cells(StartRow, 1).Offset(Counter, 0).NumberFormatLocal = nFormat(Counter)
Cells(StartRow, 1).Offset(Counter, 0).Value = nFormat(Counter)
Next Counter
Counter = 0
For Each Sh In Workbooks(ActWorkbookName).Worksheets
For Each Cell In Sh.UsedRange.Cells
fFormat = Cell.NumberFormatLocal
If Application.WorksheetFunction.CountIf(Range(Cells(StartRow, 2), Cells(EndRow, 2)), fFormat) = 0 Then
Cells(StartRow, 2).Offset(Counter, 0).NumberFormatLocal = fFormat
Cells(StartRow, 2).Offset(Counter, 0).Value = fFormat
Counter = Counter + 1
End If
Next Cell
Next Sh
xFormat = Range(Cells(StartRow, 2), Cells(EndRow, 2)).Find("").Row - 2
Counter2 = 0
For Counter = 0 To UBound(nFormat)
pPresent = False
For Counter1 = 1 To xFormat
If nFormat(Counter) = Cells(StartRow, 2).Offset(Counter1, 0).NumberFormatLocal Then
pPresent = True
End If
Next Counter1
If pPresent = False Then
Cells(StartRow, 3).Offset(Counter2, 0).NumberFormatLocal = nFormat(Counter)
Cells(StartRow, 3).Offset(Counter2, 0).Value = nFormat(Counter)
Counter2 = Counter2 + 1
End If
Next Counter
With ActiveSheet.Columns("A:C")
.AutoFit
.HorizontalAlignment = xlLeft
End With
If Answer = vbYes Then
DataStart = StartRow
DataEnd = DataStart + Counter2 - 1
On Error Resume Next
For Each Cell In Range(Cells(DataStart, 3), Cells(DataEnd, 3)).Cells
Workbooks(ActWorkbookName).DeleteNumberFormat Cell.NumberFormat
Next Cell
End If
Finito:
Set Cell = Nothing
Set Sh = Nothing
Set Buffer = Nothing
End Sub
