Sub MrExcelDiet()
' ZVI:2009-08-08 Active workbook excess formatting clearing
' Idea & original code of Just_Jon: http://www.mrexcel.com/forum/showthread.php?t=120831
' First attempt of modification: http://www.mrexcel.com/forum/showthread.php?t=339144
' Bugs tracking:
' 1. Range("A1") fixed to .Range("A1")
' 2. Exchanging:
' .EntireRow.RowHeight to ws.StandardHeight
' .EntireColumn.ColumnWidth to ws.StandardWidth
' Revised:2010-06-16
' 3.(ZVI:2010-06-16) Code for StandardHeight corrected. Comments shapes are skipped
Const Title = "MrExcelDiet: Just_Jon's code modified by ZVI"
Const vbTab2 = vbTab & vbTab
Dim Wb As Workbook, Ws As Worksheet, LastCell As Range, Shp As Shape, Chrt As Chart
Dim Prot As Boolean, ProtWarning As Boolean, DoCharts As Boolean
Dim LastRow&, LastCol&, ShpLastRow&, ShpLastCol&, i&, ac, x
Dim SheetsTotal&, SheetsCleared&, ChartsCleared&, SheetsProtSkipped&
Dim FileNameTmp$, BytesInFileOld&, BytesInFileNew&
' Choose the clearing mode
Set Wb = ActiveWorkbook
x = MsgBox("Excess formatting clearing of " & Wb.Name & vbCr & vbCr & _
"Apply full clearing?" & vbCr & vbCr & _
"Yes" & vbTab & "- Full mode, including chart's AutoScaleFont=False" & vbCr & _
"No" & vbTab & "- Medium mode, without charts processing" & vbCr & _
"Cancel" & vbTab & "- Stop clearing & Exit", _
vbInformation + vbYesNoCancel, _
Title)
If x = vbCancel Then Exit Sub
DoCharts = (x = vbYes)
' Freeze on
With Application
.ScreenUpdating = False
.EnableEvents = False
ac = .Calculation: .Calculation = xlCalculationManual
End With
' Calculate the old file size
On Error Resume Next
With CreateObject("Scripting.FileSystemObject")
FileNameTmp = .GetSpecialFolder(2) & "\" & Wb.Name & ".TMP"
Wb.SaveCopyAs FileNameTmp
BytesInFileOld = .GetFile(FileNameTmp).Size
End With
' Processing in each worksheet
ProtWarning = True
SheetsTotal = Wb.Sheets.Count
For Each Ws In Wb.Worksheets
With Ws
' Clear an error flag
Err.Clear
' Inform on processing status
Application.StatusBar = "MrExcelDiet: processing of sheet " & Ws.Name
' Check protection
Prot = .ProtectContents
' Try to unprotect without password
If Prot Then .Unprotect ""
If (Err <> 0 Or .ProtectContents) And ProtWarning Then
SheetsProtSkipped = SheetsProtSkipped + 1
x = MsgBox(Ws.Name & " is protected and will be skipped" & vbCr & vbCr & _
"Skip warning on protected sheets?" & vbCr & vbCr & _
"Yes" & vbTab & "- Skip warning, clear sheets silently" & vbCr & _
"No" & vbTab & "- Warning on each protected sheets" & vbCr & _
"Cancel" & vbTab & "- Stop clearing & Exit", _
vbExclamation + vbYesNoCancel, _
Title)
ProtWarning = (x = vbNo)
If x = vbCancel Then GoTo exit_
Else
' Count processed worksheets
SheetsCleared = SheetsCleared + 1
' Determine the last used cell with a formula or value or comment in Ws
Set LastCell = GetLastCell(Ws)
' Determine the last column and last row
If Not LastCell Is Nothing Then
LastCol = LastCell.Column
LastRow = LastCell.Row
End If
' Determine if any merged cells are beyond the last row
For Each x In Range(.Cells(LastRow, 1), .Cells(LastRow, LastCol))
If x.MergeCells Then
With x.MergeArea
LastRow = Max(LastRow, .Rows(.Rows.Count).Row)
End With
End If
Next
' Determine if any merged cells are beyond the last column
For Each x In Range(.Cells(1, LastCol), .Cells(LastRow, LastCol))
If x.MergeCells Then
With x.MergeArea
LastCol = Max(LastCol, .Columns(.Columns.Count).Column)
End With
End If
Next
' Determine if any shapes are beyond the last row and last column
ShpLastCol = LastCol
ShpLastRow = LastRow
For Each Shp In .Shapes
If Shp.Type <> msoComment Then ' ZVI:2010-06-16
ShpLastCol = Max(ShpLastCol, Shp.BottomRightCell.Column)
ShpLastRow = Max(ShpLastRow, Shp.BottomRightCell.Row)
End If
Next
' Clear cells beyond the last column
If LastCol < .Columns.Count Then
With .Range(.Columns(LastCol + 1), .Columns(.Columns.Count))
.Clear
If LastCol >= ShpLastCol Then
' Set StandardWidth to columns which are beyond the last col
.EntireColumn.ColumnWidth = IIf(Ws.StandardWidth, Ws.StandardWidth, 8.43) 'Ws.StandardWidth
End If
End With
If ShpLastCol < .Columns.Count Then
' Set StandardWidth to columns which are beyond the Shapes
With .Range(.Columns(ShpLastCol + 1), .Columns(.Columns.Count))
.EntireColumn.ColumnWidth = IIf(.StandardWidth, .StandardWidth, 8.43) 'Ws.StandardWidth
End With
End If
End If
' Clear cells beyond the last row
If LastRow < .Rows.Count Then
With .Range(.Rows(LastRow + 1), .Rows(.Rows.Count))
.Clear
If LastRow >= ShpLastRow Then
' Set StandardWidth to rows which are beyond the last row
.EntireRow.RowHeight = IIf(Ws.StandardHeight, Ws.StandardHeight, 12.75)
End If
End With
If ShpLastRow < .Rows.Count Then
' Set StandardHeight to rows which are beyond the Shapes
With .Range(.Rows(ShpLastRow + 1), .Rows(.Rows.Count))
.EntireRow.RowHeight = IIf(.StandardHeight, .StandardHeight, 12.75)
End With
End If
End If
' Reset last cell position of the sheet
With .UsedRange: End With
' Protect the sheet if it was unprotected
If Prot Then .Protect
End If
' Apply setting to worksheet's charts: ChartArea.AutoScaleFont = False
If DoCharts Then
For i = 1 To .ChartObjects.Count
Application.StatusBar = "MrExcelDiet: processing of chart " & .ChartObjects(i).Name
.ChartObjects(i).Chart.ChartArea.AutoScaleFont = False
ChartsCleared = ChartsCleared + 1
Next
End If
End With
Next
' Apply setting to workbook's charts: ChartArea.AutoScaleFont = False
If DoCharts Then
With Wb
For i = 1 To .Charts.Count
' Clear an error flag
Err.Clear
' Inform on processing status
Application.StatusBar = "MrExcelDiet: processing of chart " & .Charts(i).Name
' Check chart sheet protection
Prot = .Charts(i).ProtectContents
' Try to unprotect chart sheet without password
If Prot Then .Charts(i).Unprotect ""
If (Err <> 0 Or .Charts(i).ProtectContents) And ProtWarning Then
SheetsProtSkipped = SheetsProtSkipped + 1
x = MsgBox(Ws.Name & " is protected and will be skipped" & vbCr & vbCr & _
"Skip warning on protected sheets?" & vbCr & vbCr & _
"Yes" & vbTab & "- Skip warning, clear sheets silently" & vbCr & _
"No" & vbTab & "- Warning on each protected sheets" & vbCr & _
"Cancel" & vbTab & "- Stop clearing & Exit", _
vbExclamation + vbYesNoCancel, _
Title)
ProtWarning = (x = vbNo)
If x = vbCancel Then GoTo exit_
Else
' Set AutoScaleFont = False for chart sheet
.Charts(i).ChartArea.AutoScaleFont = False
SheetsCleared = SheetsCleared + 1
ChartsCleared = ChartsCleared + 1
' Protect the chart sheet if it was unprotected
If Prot Then .Charts(i).Protect
End If
Next
End With
End If
exit_:
' Calculate the new file size
Wb.SaveCopyAs FileNameTmp
BytesInFileNew = CreateObject("Scripting.FileSystemObject").GetFile(FileNameTmp).Size
Kill FileNameTmp
' Freeze off
With Application
.Calculation = ac
.ScreenUpdating = True
.EnableEvents = True
End With
' Report on results
Application.StatusBar = False
x = MsgBox("Statistics of excess formatting clearing" & vbLf & vbLf & _
"Workbook:" & vbTab & ActiveWorkbook.Name & "'" & vbLf & _
"Sheets total:" & vbTab2 & SheetsTotal & vbLf & _
"Sheets cleared:" & vbTab2 & SheetsCleared & vbLf & _
"Protected sheets skipped: " & vbTab & SheetsProtSkipped & vbLf & _
"Other sheets skipped:" & vbTab & SheetsTotal - SheetsCleared - SheetsProtSkipped & vbLf & _
"Charts cleared:" & vbTab2 & ChartsCleared & vbLf & _
"File size old:" & vbTab & Format(BytesInFileOld, "# ### ##0") & " Bytes" & vbLf & _
"File size new:" & vbTab & Format(BytesInFileNew, "# ### ##0") & " Bytes" & vbLf & _
vbLf & _
"Save the cleared workbook to keep the changes?" & vbLf & _
"Yes" & vbTab & "- Save & Exit" & vbLf & _
"No" & vbTab & "- Exit without saving, cleared", _
vbInformation + vbYesNo + IIf(BytesInFileNew < BytesInFileOld, vbDefaultButton1, vbDefaultButton2), _
Title)
If x = vbYes Then Wb.Save
End Sub
' ZVI:2009-02-02 Get last cell within values/formulas/comments of sheet Sh
' Auto-filtered & hidden rows/columns are also calculated without ShowAllData
' ActiveSheet is used if optional Sh is missing
' If VisibleOnly=True then only visible cells are searched
Function GetLastCell(Optional Sh As Worksheet, Optional VisibleOnly As Boolean) As Range
Dim SpecCells(), Rng As Range, r&, c&, x, a
SpecCells = Array(xlCellTypeConstants, xlCellTypeFormulas, xlCellTypeComments)
On Error Resume Next
If Sh Is Nothing Then Set Sh = ActiveSheet
Set Rng = Sh.UsedRange
If VisibleOnly Then Set Rng = Rng.SpecialCells(xlCellTypeVisible)
For Each x In SpecCells
For Each a In Rng.SpecialCells(x).Areas
With a.Cells(a.Rows.Count, a.Columns.Count)
c = Max(c, .Column)
r = Max(r, .Row)
End With
Next
Next
If r * c <> 0 Then Set GetLastCell = Sh.Cells(r, c)
End Function
' Aux function: max value of arguments
Private Function Max(ParamArray Values())
Dim x
For Each x In Values
If x > Max Then Max = x
Next
End Function |
