Sub ExcelSheetSizeReducerV1()
'
' *** FYI, Can't reduce the size of protected sheets. ;)
'
'-----------------------------------------------------------------------------------------------
'
Dim startTime As Single
startTime = Timer ' Start the stopwatch
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
Application.DisplayAlerts = False ' Turn DisplayAlerts off
'
'-----------------------------------------------------------------------------------------------
'
Dim RowHeightsAltered As Boolean
Dim ArrayRow As Long
Dim EndRangeRow As Long, RowHeightArrayRow As Long, StartRangeRow As Long
Dim LastColumn As Long, LastRow As Long
Dim LastColumnRowAddressFormula As Long, LastColumnRowAddressValue As Long
Dim LastRowColumnAddressFormula As Long, LastRowColumnAddressValue As Long
Dim ShapeTopLeftCellRow As Long, ShapeTopLeftCellColumn As Long
Dim rng As Range
Dim Shp As Shape
Dim MaxRowHeight As Single
Dim RowHeightArray As Variant
'
'-----------------------------------------------------------------------------------------------
'
With ThisWorkbook.ActiveSheet
'
'-----------------------------------------------------------------------------------------------
'
If .UsedRange.Rows.Count = Range("A" & Rows.Count).Row Then ' If a problematic sheet is discovered then ...
'
' Save row heights & the ranges of those row heights of current sheet into RowHeightArray
Set rng = .Range("A1:A" & .Range("A" & .Rows.Count - 1).Row) ' Set the range to search through
'
ReDim RowHeightArray(1 To rng.Rows.Count + 1, 1 To 2) ' Set the # of rows/columns of RowHeightArray
'
StartRangeRow = 1 ' Initialize StartRangeRow
RowHeightArrayRow = 0 ' Initialize RowHeightArrayRow
'
For EndRangeRow = 1 To rng.Rows.Count ' Loop through the cells of of the rows of column
If .Range("" & "A" & EndRangeRow & "").Height <> .Range("" & _
"A" & EndRangeRow + 1 & "").Height Then ' If this cell value <> next cell value then ...
RowHeightArrayRow = RowHeightArrayRow + 1 ' Increment the RowHeightArrayRow
RowHeightArray(RowHeightArrayRow, 1) = .Range("" & _
"A" & EndRangeRow & "").Height ' Save cell value into 1st column of RowHeightArray
RowHeightArray(RowHeightArrayRow, 2) = "A" & _
StartRangeRow & ":" & "A" & EndRangeRow ' Save Address range to 2nd column of RowHeightArray
StartRangeRow = EndRangeRow + 1 ' Set the next StartRangeRow for next address
End If
Next ' Loop back
'
' Get last set of values
RowHeightArrayRow = RowHeightArrayRow + 1 ' Increment the RowHeightArrayRow
RowHeightArray(RowHeightArrayRow, 1) = .Range("" & "A" & EndRangeRow & "").Height ' Save cell value into 1st column of RowHeightArray
RowHeightArray(RowHeightArrayRow, 2) = "A" & StartRangeRow & ":" & "A" & EndRangeRow ' Save Address range to 2nd column of RowHeightArray
'
' All different row heights as well as the ranges of those row heights of this sheet are now saved into 2D 1 based RowHeightArray RC
'
'-----------------------------------------------------------------------------------------------
'
' Find Maximum row height in the array
MaxRowHeight = 0# ' Initialize MaxRowHeight
'
For ArrayRow = 1 To RowHeightArrayRow ' Loop through the RowHeightArray saved heights
If RowHeightArray(ArrayRow, 1) > MaxRowHeight Then ' If a RowHeight is found > MaxRowHeight then ...
MaxRowHeight = RowHeightArray(ArrayRow, 1) + 1 ' Add 1 to the found RowHeight & Save it as MaxRowHeight
End If
Next ' Loop back
'
'-----------------------------------------------------------------------------------------------
'
' Set all Row Heights to the same height
On Error Resume Next ' Ignore Protected sheet error
.Cells.RowHeight = MaxRowHeight ' Set all row heights to same height
RowHeightsAltered = True ' Turn RowHeightsAltered flag on
On Error GoTo 0 ' Turn off Error ignore
End If
'
'-----------------------------------------------------------------------------------------------
'
' Resume normal script
On Error Resume Next
LastColumnRowAddressFormula = .Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column ' Address of Last row cell in Last Column
LastColumnRowAddressValue = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column ' Address of Last row cell in Last Column
'
LastRowColumnAddressFormula = .Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row ' Address of Last column cell in Last Row
LastRowColumnAddressValue = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row ' Address of Last column cell in Last Row
On Error GoTo 0
'
'-----------------------------------------------------------------------------------------------
'
' Determine the last column
LastColumn = LastColumnRowAddressFormula
'
If LastColumnRowAddressValue <> 0 Then
LastColumn = Application.WorksheetFunction.Max(LastColumn, LastColumnRowAddressValue) ' Set LastColumn to the maximum value of the 2
End If
'
'-----------------------------------------------------------------------------------------------
'
' Determine the last row
LastRow = LastRowColumnAddressFormula
'
If LastRowColumnAddressValue <> 0 Then
LastRow = Application.WorksheetFunction.Max(LastRow, LastRowColumnAddressValue) ' Set LastRow to the maximum value of the 2
End If
'
'-----------------------------------------------------------------------------------------------
'
' Determine if any shapes are beyond the last row and last column
For Each Shp In .Shapes
ShapeTopLeftCellRow = 0
ShapeTopLeftCellColumn = 0
'
On Error Resume Next
ShapeTopLeftCellRow = Shp.TopLeftCell.Row
ShapeTopLeftCellColumn = Shp.TopLeftCell.Column
On Error GoTo 0
'
If ShapeTopLeftCellRow > 0 And ShapeTopLeftCellColumn > 0 Then
Do Until .Cells(ShapeTopLeftCellRow, ShapeTopLeftCellColumn).Top > Shp.Top + Shp.Height
ShapeTopLeftCellRow = ShapeTopLeftCellRow + 1
Loop
'
If ShapeTopLeftCellRow > LastRow Then
LastRow = ShapeTopLeftCellRow
End If
'
Do Until .Cells(ShapeTopLeftCellRow, ShapeTopLeftCellColumn).Left > Shp.Left + Shp.Width
ShapeTopLeftCellColumn = ShapeTopLeftCellColumn + 1
Loop
'
If ShapeTopLeftCellColumn > LastColumn Then
LastColumn = ShapeTopLeftCellColumn
End If
End If
Next
'
'-----------------------------------------------------------------------------------------------
'
' Delete the columns & Rows
On Error Resume Next ' Ignore Protected sheet error
If LastColumn < .Columns.Count Then .Range(.Cells(1, LastColumn + 1), _
.Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete ' Delete Columns
If LastRow < .Rows.Count Then .Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete ' Delete Rows
On Error GoTo 0 ' Turn off Error ignore
End With
'
'-----------------------------------------------------------------------------------------------
'
' Check to see if we need to restore the previous sheet's original row heights
If RowHeightsAltered = True Then ' If the RowHeights had to be altered then ...
For ArrayRow = 1 To RowHeightArrayRow ' Loop through the RowHeightArray
Range("" & RowHeightArray(ArrayRow, 2) & "").RowHeight = RowHeightArray(ArrayRow, 1) ' Return the row height back to original
Next ' Loop back
'
RowHeightsAltered = False ' Turn RowHeightsAltered flag off
End If
'
'-----------------------------------------------------------------------------------------------
'
PathFromFileToFix = Application.ThisWorkbook.Path ' Get file path of current file
OriginalFileName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) ' Save the UserFilePath with NoExtension
UserFileExtension = Right(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - _
InStrRev(ActiveWorkbook.Name, ".") + 1) ' Save the UserFileExtension
ActiveWorkbook.SaveAs Filename:=PathFromFileToFix & "\" & OriginalFileName & "_Shortened" & UserFileExtension ' Automatically save the 'shortened' size workbook
'
'-----------------------------------------------------------------------------------------------
'
Application.DisplayAlerts = True ' Turn DisplayAlerts back on
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'
Debug.Print "Time to complete = " & Timer - startTime & " seconds." ' about xx.xx seconds
'
MsgBox "Completed!" ' Let user know that the process is complete
End Sub
