终极解决EXCEL“不同单元格格式太多”的问题

1 / 5
终极解决EXCEL“不同单元格格式太多”的问题
2009-06-24 14:35
在格式超过4000的Excel表里录制一个新宏，内容如下所示：
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 Dummy As Variant
Dim pPresent As Boolean
Dim NumberOfFormats As Long
Dim Answer
Dim c As Object
Dim DataStart As Long
2 / 5

Dim DataEnd As Long
Dim AnswerText As String
NumberOfFormats = 1000
ReDim nFormat(0 To NumberOfFormats)
AnswerText = "Do you want to delete unused custom formats from
theworkbook?"

AnswerText = AnswerText & Chr(10) & "To get a list of used and unusedformats
only, choose No."

Answer = MsgBox(AnswerText, 259)
If Answer = vbCancel Then GoTo Finito
On Error GoTo Finito
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "CustomFormats"
Worksheets("CustomFormats").Activate
Set Buffer = Range("A2")
Buffer.Select
nFormat(0) = Buffer.NumberFormatLocal
Counter = 1
Do
SaveFormat = Buffer.NumberFormatLocal
Dummy = Buffer.NumberFormatLocal
DoEvents
3 / 5

SendKeys "{tab 3}{down}{enter}"
Application.Dialogs(xlDialogFormatNumber).Show Dummy
nFormat(Counter) = Buffer.NumberFormatLocal
Counter = Counter + 1
Loop Until nFormat(Counter - 1) = SaveFormat
ReDim Preserve nFormat(0 To Counter - 2)
Range("A1").Value = "Custom formats"
Range("B1").Value = "Formats used in workbook"
Range("C1").Value = "Formats not used"
Range("A1:C1").Font.Bold = True
StartRow = 3
EndRow = 16384
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 ActiveWorkbook.Worksheets
If Sh.Name = "CustomFormats" Then Exit For
For Each c In Sh.UsedRange.Cells
fFormat = c.NumberFormatLocal
4 / 5

If Application.WorksheetFunction.CountIf(Range(Cells(StartRow,
2),Cells(EndRow, 2)), fFormat) = 0 Then

Cells(StartRow, 2).Offset(Counter, 0).NumberFormatLocal =
fFormatCells(StartRow, 2).Offset(Counter, 0).Value = fFormat

Counter = Counter + 1
End If
Next c
Next Sh
xFormat = Range(Cells(StartRow, 2), Cells(EndRow, 2)).Find("").Row - 2Counter2
= 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
5 / 5

End If
Next Counter
With ActiveSheet.Columns("A:C")
.AutoFit
.HorizontalAlignment = xlLeft
End With
If Answer = vbYes Then
DataStart = Range(Cells(1, 3), Cells(EndRow, 3)).Find("").Row + 1DataEnd =
Cells(DataStart, 3).Resize(EndRow, 1).Find("").Row - 1On Error Resume Next

For Each c In Range(Cells(DataStart, 3), Cells(DataEnd,
3)).CellsActiveWorkbook.DeleteNumberFormat (c.NumberFormat)

Next c
End If
Finito:
Set c = Nothing
Set Sh = Nothing
Set Buffer = Nothing
End Sub
执行此宏后，Excel表即可继续设置单元格格式。