Reducing workbook file size

[johnnyL]

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.

        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:

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 Sub

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.

 

[Dan_W]

As regards the first question, I just checked, and it turns out that there IS another way(s) of checking the various heights - whether or not it's faster than your approach depends, I suspect, on the number of rows in question and the degree to which you think they've been changed.

Option A: You can always open up the file and check the XML code of the worksheet...

<sheetFormatPr defaultRowHeight="15.75" x14ac:dyDescent="0.25"/><sheetData>
<row r="2" spans="1:3" ht="34.5" customHeight="1" x14ac:dyDescent="0.25"><c r="A2" t="s">
<v>0</v></c></row><row r="4" spans="1:3" ht="9.75" customHeight="1" x14ac:dyDescent="0.25">

As you can see from the above, the default height is 15.75, I doubled the height for row 2, and it is now 34.5, and I halved the height for row 4, which is now 9.75. You can also see that there is a 'customHeight' flag being set too. Admittedly, this is quite a sledgehammer-to-a-walnut sort of solution... but tremendously accurate!

In case you were interested, the above XML code was located in xl > worksheets > Sheet1.xml

Option B: You can test whether or not there is any variance in a range/column by checking the Selection.Height - when you know that the default height is 15 (20 pixels), then you might be able to surmise that if the height of a selection of 10 cells is 150 (200 pixels), then they're probably all at default height. It wouldn't be 100% reliable, but it might be a good barometer to then decide whether or not you need to look at the row heights in closer detail...?

 

[johnnyL]

Food for thought @Dan_W Thank you. I will take that into consideration.

 

[johnnyL]

@Dan_W upon further investigation, It appears that the only row heights that need to be altered are the rows in the 'unused' range.

If those rows are altered to a preset size, file saved, altered back to default size, it works!

 

[Dan_W]

Awesome. Useful to know. Perhaps research worthy of an Article on the forum?

Do you need to actually go off an alter the size, though? If they're unused, wouldn't it be quicker just to bulk delete the columns/cells, at which point they're replaced with cells of the default size? Or is that what you did/

 

[johnnyL]

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.

I will provide a link to a sample file that has these 'Phantom' rows.

There is also a macro in it that lists the results, in the 'Immediate Window', of what should be the LastRow address (M300) and the Ctrl+End result (M1048576).
Here is the macro code:

Sub LastRows()
'
    Dim LastCell    As Range
    Dim RowValue    As Range
'
    Set RowValue = Cells.Find("*", , xlValues, , xlByRows, xlPrevious)
    Debug.Print RowValue.Address(0, 1)
'
    Set LastCell = ActiveCell.SpecialCells(xlLastCell)                      ' Ctrl+End equivalent
    Debug.Print LastCell.Address(0, 1)
End Sub

If you try to delete those rows from 301 to the bottom and then save the file. When the file is reopened, all those extra unused rows are still there and being seen, most noticeably by the very long right hand scroll bar, not to mention the very large file size that remains.

MrExcel took a look at a similar example here <---. His only solution was to hide the rows. Of course this still leaves a very large Excel file because those extra rows are taking up a lot of file space.

The link to the test file to play with is here <---.

 

[johnnyL]

Updated version of the code I had been working on. I have revised my approach and did some speed ups.

Let me know of any alterations that should be made.

Sub ExcelFileSizeReducerV3_61()
'
'   *** FYI, Can't reduce the size of protected sheets. ;)
'
'-----------------------------------------------------------------------------------------------
'
'
    Dim UserSelectedExcelFile       As Variant
'
    UserSelectedExcelFile = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*", _
            Title:="Browse to the Excel file that you would like to reduce the file size of")   ' Ask the user to select the excel file to try and reduce size of
'
    If UserSelectedExcelFile = False Then                                                       ' If user chose to quit then ...
        MsgBox "No file selected - exiting"                                                     '   Display message box to user indicating the cancellation
        Exit Sub                                                                                '   Exit the sub
    End If
'
'-------------------------
'
    Dim BeginstartTime              As Single
    Dim startTime                   As Single
    startTime = Timer                                                                           ' Start the stopwatch
'
    Application.ScreenUpdating = False                                                          ' Turn ScreenUpdating off
     Application.DisplayAlerts = False                                                          ' Turn DisplayAlerts off
'
    Dim LastRow                     As Long, LastColumn                 As Long
    Dim ShapeTopLeftCellRow         As Long, ShapeTopLeftCellColumn     As Long
    Dim FSO                         As Object
    Dim Shp                         As Shape
    Dim TimeToLoadFile              As Single, TimeToCloseFile          As Single, TotalLoadCloseFileTime   As Single
    Dim TotalRunTime                As Single, TotalSheetTime           As Single
    Dim ExcelReportedLastCell       As String, ExpectedLastCell         As String, ResetExcelLastAddress    As String
    Dim WorkbookFilePathNoExtension As String, WorkbookExtension        As String, RenamedSourceFile        As String
    Dim wbSource                    As Workbook
    Dim ws                          As Worksheet
'
'-------------------------
'
    WorkbookFilePathNoExtension = Left(UserSelectedExcelFile, _
            InStrRev(UserSelectedExcelFile, ".") - 1)                                           ' Save the WorkbookFilePathNoExtension with NoExtension
    WorkbookExtension = Right(UserSelectedExcelFile, _
            Len(UserSelectedExcelFile) - InStrRev(UserSelectedExcelFile, ".") + 1)              ' Save the WorkbookExtension
'
    RenamedSourceFile = WorkbookFilePathNoExtension & "_Shortened" & WorkbookExtension          ' Set Name of RenamedSourceFile to use
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Call FSO.CopyFile(UserSelectedExcelFile, RenamedSourceFile)                                 ' Copy/Rename user selected file to RenamedSourceFile
'
    Set wbSource = Workbooks.Open(RenamedSourceFile)                                            ' Open the RenamedSourceFile
'
    TimeToLoadFile = Timer - startTime                                                          ' Save the Time it took to Rename & Load File
'
'-------------------------
'
    For Each ws In wbSource.Worksheets                                                          ' Loop through each worksheet in selected workbook
        With ws
            LastRow = .Cells.Find(What:="*", SearchOrder:=xlRows, _
                    SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row                        '       Save Last used row
            LastColumn = .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column                     '       Save Last used column
'
'       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 Rows & Columns
            On Error Resume Next                                                                    '   Ignore Protected sheet error
            If LastRow < .Rows.Count Then .Rows("" & LastRow + 1 & ":" & .Rows.Count & "").Select   '   If there are rows to delete then Select them
            Selection.Delete                                                                        '   Delete selected Rows
'
            If LastColumn < .Columns.Count Then .Columns("" & LastColumn + 1 & _
                    ":" & .Columns.Count & "").Select                                               '   If there are columns to delete then Select them
            Selection.Delete                                                                        '   Delete selected Columns
'
            ResetExcelLastAddress = .UsedRange.Address                                              '   Reset Last row of sheet without saving file
'
'-------------------
'
'       Check if excel is reporting different Last cell than what is expected
            ExpectedLastCell = "$" & Split(Cells(1, (.Cells.Find("*", , xlFormulas, _
                    , xlByColumns, xlPrevious).Column)).Address, "$")(1) & LastRow                  '   Save ExpectedLastCell
            ExcelReportedLastCell = .Cells.SpecialCells(xlLastCell).Address(0, 1)                   '   Save Ctrl+End equivalent to ExcelReportedLastCell
'
            If ExpectedLastCell <> ExcelReportedLastCell Then                                       '   If there is a discrepency about last cell then ...
                With .Range("A" & LastRow + 1 & ":A" & .Rows.Count)                                 '       Loop through unused rows
                    .RowHeight = 16.25                                                              '           Set unused rows to same height
                End With
''                .Rows("" & LastRow + 1 & ":" & .Rows.Count & "").Select                             '       Select the rows that will have height altered
''                Selection.RowHeight = 16.25                                                         '           Set unused rows to same height
'
                If LastRow < .Rows.Count Then .Rows("" & LastRow + 1 & ":" & .Rows.Count & "").Select   '       If there are rows to delete then Select them
                Selection.Delete                                                                    '       Delete selected Rows
'
                If LastColumn < .Columns.Count Then .Columns("" & LastColumn + 1 & _
                        ":" & .Columns.Count & "").Select                                           '       If there are columns to delete then Select them
                Selection.Delete                                                                    '       Delete selected Columns
'
                ResetExcelLastAddress = .UsedRange.Address                                          '       Reset Last used address of sheet without saving file
'
                .Rows("" & LastRow + 1 & ":" & .Rows.Count & "").Select                             '       Select the rows to reset to default height
                Selection.UseStandardHeight = True                                                  '           Set unused rows to default height
            End If
'
            On Error GoTo 0                                                                         '   Turn off Error ignore
        End With
    Next                                                                                            ' Loop back
'
'-------------------
'
    BeginstartTime = Timer                                                                          ' Start the stopwatch
    ActiveWorkbook.Close savechanges:=True                                                          ' Save & Close the 'shortened' workbook
    TimeToCloseFile = Timer - BeginstartTime                                                        ' Save the time it took to save & close the workbook
'
     Application.DisplayAlerts = True                                                               ' Turn DisplayAlerts back on
    Application.ScreenUpdating = True                                                               ' Turn ScreenUpdating back on
'
    TotalLoadCloseFileTime = TimeToLoadFile + TimeToCloseFile                                       ' Save Total time to load/save/close file into TotalLoadCloseFileTime
              TotalRunTime = Timer - startTime                                                      ' Save Total time to run the script into TotalRunTime
            TotalSheetTime = TotalRunTime - TotalLoadCloseFileTime                                  ' Calculate time it took to reduce sheet sizes
'
    Debug.Print "Time to Open and Save/Close File = " & TotalLoadCloseFileTime & " seconds."                ' Display Total time to load/save/close file
    Debug.Print "Time to Reduce the size of the sheets in the workbook = " & TotalSheetTime & " seconds."   ' Display Total time to reduce sheet sizes
    Debug.Print "Total Time to Complete = " & TotalRunTime & " seconds."                                    ' Display Total time to complete script
'
MsgBox "Completed!"                                                                                         ' Let user know that the process is complete
End Sub

 

[Alex Blakenburg]

@johnnyL, I had an issue with the sheets Paper 1 and Paper 2, in that the reset of the end of sheet left them both still showing row 300 (s/be 126 & 122 respectively). Changing the below seemed to fix it for me.
Note: they are hidden sheets

                ' XXX removed select
                If LastRow < .Rows.Count Then .Rows("" & LastRow + 1 & ":" & .Rows.Count & "").Delete   '       If there are rows to delete then Select them

                ' XXX removed select
                If LastColumn < .Columns.Count Then .Columns("" & LastColumn + 1 & _
                        ":" & .Columns.Count & "").Delete                                           '       If there are columns to delete then Select them                                                                  '       Delete selected Columns
'
                ResetExcelLastAddress = .UsedRange.Address                                          '       Reset Last used address of sheet without saving file
'
                ' XXX removed select
                .Rows("" & LastRow + 1 & ":" & .Rows.Count & "").UseStandardHeight = True                             '       Select the rows to reset to default height

 

[johnnyL]

Hmm. How did I miss those selects? I should have already removed them. I guess when you stare at things long enough, you see what isn't there, and don't see what is there.

Thank you for the assist @Alex Blakenburg.

 

[Alex Blakenburg]

Thanks @johnnyL, I will switch over to using your code.