Reduce File Size

sspatriots

Well-known Member
Joined
Nov 22, 2011
Messages
545
Office Version
  1. 365
Platform
  1. Windows
My file has blown up in size and I need to shrink it a bit. I tried the ExcelDiet code below, but it get's hung up at the following line:

VBA Code:
.Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete


Any help would be greatly appreciated. Thank you, SS


VBA Code:
Option Explicit

Sub ExcelDiet()


Dim j               As Long
Dim k               As Long
Dim LastRow         As Long
Dim LastCol         As Long
Dim ColFormula      As Range
Dim RowFormula      As Range
Dim ColValue        As Range
Dim RowValue        As Range
Dim Shp             As Shape
Dim ws              As Worksheet


    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
        
    On Error Resume Next


    For Each ws In Worksheets
        With ws
            'Find the last used cell with a formula and value
            'Search by Columns and Rows
            On Error Resume Next
            Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
            Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            On Error GoTo 0
                    
            'Determine the last column
            If ColFormula Is Nothing Then
                LastCol = 0
            Else
                LastCol = ColFormula.Column
            End If
            If Not ColValue Is Nothing Then
                LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
            End If
                            
            'Determine the last row
            If RowFormula Is Nothing Then
                LastRow = 0
            Else
                LastRow = RowFormula.Row
            End If
            If Not RowValue Is Nothing Then
                LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
            End If
                
            'Determine if any shapes are beyond the last row and last column
            For Each Shp In .Shapes
                j = 0
                k = 0
                On Error Resume Next
                j = Shp.TopLeftCell.Row
                k = Shp.TopLeftCell.Column
                On Error GoTo 0
                If j > 0 And k > 0 Then
                    Do Until .Cells(j, k).Top > Shp.Top + Shp.Height
                        j = j + 1
                    Loop
                    If j > LastRow Then
                        LastRow = j
                    End If
                    Do Until .Cells(j, k).Left > Shp.Left + Shp.Width
                        k = k + 1
                    Loop
                    If k > LastCol Then
                        LastCol = k
                    End If
                End If
            Next
                    
            .Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete
            .Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete
        End With
    Next
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

Sub RemoveTheStyles()
 
    Dim style               As style
    Dim l_counter           As Long
    Dim l_total_number      As Long
 
    On Error Resume Next
 
    l_total_number = ActiveWorkbook.Styles.Count
    Application.ScreenUpdating = False
 
    For l_counter = l_total_number To 1 Step -1
    
        Set style = ActiveWorkbook.Styles(l_counter)
        
        If (l_counter Mod 500 = 0) Then
            DoEvents
            Application.StatusBar = "Deleting " & l_total_number - l_counter + 1 & " of " & l_total_number & " " & style.Name
        End If
        
        If Not style.BuiltIn Then style.Delete
 
    Next l_counter
 
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Debug.Print "READY!"
    
    On Error GoTo 0
End Sub
 

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
It sounds like your sheet may be protected. If so, it won't allow you to delete.
 
Upvote 0
This workbook has a lot of worksheets in it. Is there a way to easily see what worksheets may be protected?
 
Upvote 0
If you select File, Info, it will show the protected sheets.
 
Upvote 0
You could do something like the following if you want the script to continue running and display protected sheets at the end:

Add
Dim ProtectedSheetsMessage as string
to the 'Dim' section at the top of the code.

Then Replace the following code:
VBA Code:
            .Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete
            .Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete
        End With
    Next
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

with:
VBA Code:
            On Error GoTo ErrorHandler                                                                      '   If error occurs then likely Protected sheet error
            If LastCol < .Columns.Count Then .Range(.Cells(1, LastCol + 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
'
StopOurErrorHandler:
            On Error GoTo 0                                                                                 '   Turn off Error ignore
        End With
    Next
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
'
    If Len(ProtectedSheetsMessage) > 0 Then
        MsgBox "Protected sheets that could not be altered:" & vbCrLf & ProtectedSheetsMessage
    End If
    Exit Sub
'
ErrorHandler:
    ProtectedSheetsMessage = ProtectedSheetsMessage & ws.Name & vbCrLf
    Resume StopOurErrorHandler
End Sub
 
Upvote 0
Thanks, I ended up finding one sheet that was the culprit and manually deleted the blank rows and the file got back to the size it was before. I couldn't find any protected sheets.
 
Upvote 0
I went back and ran the original code against my file after I had manually removed the unused rows that one worksheet that was making the file so large and the code ran fine. There was something about that one worksheet that the code did not like. There were no protected worksheets in the workbook. Really weird.
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,920
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top