This is a project that I recently started inspired by a recent thread that I started.
I have 2 questions right now. I have created some code that attempts to reduce the size of the active sheet in a workbook.
Some workbook sheets are weird in the fact that if the user tries to delete rows from the sheet. Save workbook & then reopen the workbook, the formerly deleted rows are still there.
I have created some code to solve that issue, inspired by a previous post from @Fluff that suggested to alter the row heights of the sheet.
The code basically loops through every cell row and saves the different row heights & the ranges associated with those different row heights.
That is the first part I need help with ... It works, but it is very slow to loop through 1045876 rows. Is there a faster way to capture the various row heights and ranges of them into an array?
The following is the entire code I insert into a current workbook to then execute on the active page:
The second question would be how to run the better above code on an entire workbook.
What I have tried works fine for the active sheet, but when I try to get it to loop through all sheets, it doesn't reduce the file size by that much.
I have 2 questions right now. I have created some code that attempts to reduce the size of the active sheet in a workbook.
Some workbook sheets are weird in the fact that if the user tries to delete rows from the sheet. Save workbook & then reopen the workbook, the formerly deleted rows are still there.
I have created some code to solve that issue, inspired by a previous post from @Fluff that suggested to alter the row heights of the sheet.
The code basically loops through every cell row and saves the different row heights & the ranges associated with those different row heights.
VBA Code:
If .UsedRange.Rows.Count = Range("A" & Rows.Count).Row Then ' If a problematic sheet is discovered then ...
'
''Debug.Print "Problematic Sheet - " & .Name ' Troubleshoot code
' 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
'
'-----------------------------------------------------------------------------------------------That is the first part I need help with ... It works, but it is very slow to loop through 1045876 rows. Is there a faster way to capture the various row heights and ranges of them into an array?
The following is the entire code I insert into a current workbook to then execute on the active page:
VBA Code:
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
''Debug.Print "Sheet being processed - " & .Name ' Troubleshoot code
'
'-----------------------------------------------------------------------------------------------
'
If .UsedRange.Rows.Count = Range("A" & Rows.Count).Row Then ' If a problematic sheet is discovered then ...
'
''Debug.Print "Problematic Sheet - " & .Name ' Troubleshoot code
' 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
'
'-----------------------------------------------------------------------------------------------
'
UserFilePathNoExtension = 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:=UserFilePathNoExtension & "_Test1" & 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 SubThe second question would be how to run the better above code on an entire workbook.
What I have tried works fine for the active sheet, but when I try to get it to loop through all sheets, it doesn't reduce the file size by that much.
