[RESOLVED] XSFormatCleaner errors - Excel 2007
XSFormatCleaner errors with 'Application-defined or object-defined error'. The command that fails is the 'ur.clear' as the 'Msgbox 1' command never gets executed.
Code:
Sub ClearExcessRowsAndColumns()
Dim ar As Range, r As Double, c As Double, tr As Double, tc As Double
Dim wksWks As Worksheet, ur As Range, arCount As Integer, i As Integer
Dim blProtCont As Boolean, blProtScen As Boolean, blProtDO As Boolean
Dim shp As Shape
On Error Resume Next
For Each wksWks In ActiveWorkbook.Worksheets
Err.Clear
'Store worksheet protection settings and unprotect if protected.
blProtCont = wksWks.ProtectContents
blProtDO = wksWks.ProtectDrawingObjects
blProtScen = wksWks.ProtectScenarios
wksWks.Unprotect ""
If Err.Number = 1004 Then
Err.Clear
MsgBox "'" & wksWks.Name & _
"' is protected with a password and cannot be checked." _
, vbInformation
Else
Application.StatusBar = "Checking " & wksWks.Name & ", Please Wait..."
r = 0
c = 0
'Determine if the sheet contains both formulas and constants
Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), _
wksWks.UsedRange.SpecialCells(xlCellTypeFormulas))
'If both fails, try constants only
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants)
End If
'If constants fails then set it to formulas
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)
End If
'If there is still an error then the worksheet is empty
If Err.Number <> 0 Then
Err.Clear
If wksWks.UsedRange.Address <> "$A$1" Then
ur.EntireRow.Delete
Else
Set ur = Nothing
End If
End If
'On Error GoTo 0
If Not ur Is Nothing Then
arCount = ur.Areas.Count
'determine the last column and row that contains data or formula
For Each ar In ur.Areas
i = i + 1
tr = ar.Range("A1").Row + ar.Rows.Count - 1
tc = ar.Range("A1").Column + ar.Columns.Count - 1
If tc > c Then c = tc
If tr > r Then r = tr
Next
'Determine the area covered by shapes
'so we don't remove shading behind shapes
For Each shp In wksWks.Shapes
tr = shp.BottomRightCell.Row
tc = shp.BottomRightCell.Column
If tc > c Then c = tc
If tr > r Then r = tr
Next
Application.StatusBar = "Clearing Excess Cells in " & _
wksWks.Name & ", Please Wait..."
Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Rows.Count)
ur.Clear
MsgBox 1
'Reset row height which can also cause the lastcell to be innacurate
ur.EntireRow.RowHeight = _
wksWks.StandardHeight
Set ur = wksWks.Range(wksWks.Cells(1, c + 1), _
wksWks.Cells(1, 256)).EntireColumn
'Reset column width which can also cause the lastcell to be innacurate
ur.EntireColumn.ColumnWidth = _
wksWks.StandardWidth
End If
End If
'Reset protection.
wksWks.Protect "", blProtDO, blProtCont, blProtScen
Err.Clear
Next
Application.StatusBar = False
MsgBox "'" & ActiveWorkbook.Name & _
"' has been cleared of excess formatting." & Chr(13) & _
"You must save the file to keep the changes.", vbInformation
End Sub
Please help. Thanks.