BUY EXCEL BOOKS ONLINE: 1. VBA & Macros      2. VBA for Modelers      3. Excel 2013 VBA and Macros     
4. Excel VBA for Dummies      5. Excel with VBA & .NET      6. Mastering VBA      7. Excel 2013 Programming

SHRINK REDUCE EXCEL FILE SIZE

When you received the file, the size was in Kbs or not more than 5-6 Mbs but when you checked it, did very little or negligible things, and saved your workbook, you found out the file size has been bloated to 3 to 100 times. It is possible, it happens in Excel. So don't worry too much.

Source of issue: First understand the difference between 'Excel Default Last Cell' and 'Actual Last Cell'. When you do 'Ctrl+End' to find last cell, you'll reach to 'Excel Default Last Cell' which may be the 'Actual Last Cell' or beyond the 'Actual Last Cell'. The more beyond 'Excel Default Last Cell' would be from 'Actual Last Cell', the more unnecessary size of excel workbook would it be having.

Solution: Delete all rows and columns beyond the 'Actual Last Cell' in every worksheet. If there are too many worksheets and large sets of data, you can use the VBA macro mentioned below.



Option Explicit
Sub SHRINK_EXCEL_FILE_SIZE()

    Dim WSheet As Worksheet
    Dim CSheet As String 'New Worksheet
    Dim OSheet As String 'Old WorkSheet
    Dim Col As Long
    Dim ECol As Long 'Last Column
    Dim lRow As Long
    Dim BRow As Long 'Last Row
    Dim Pic As Object
  
    For Each WSheet In Worksheets
        WSheet.Activate
         'Put the sheets in a variable to make it easy to go back and forth
        CSheet = WSheet.Name
         'Rename the sheet to its name with _Delete at the end
        OSheet = CSheet & "_Delete"
        WSheet.Name = OSheet
         'Add a new sheet and call it the original sheets name
        Sheets.Add
        ActiveSheet.Name = CSheet
        Sheets(OSheet).Activate
         'Find the bottom cell of data on each column and find the further row
        For Col = 1 To Columns.Count 'Find the actual last bottom row
            If Cells(Rows.Count, Col).End(xlUp).Row > BRow Then
                BRow = Cells(Rows.Count, Col).End(xlUp).Row
            End If
        Next
      
         'Find the end cell of data on each row that has data and find the furthest one
        For lRow = 1 To BRow 'Find the actual last right column
            If Cells(lRow, Columns.Count).End(xlToLeft).Column > ECol Then
                ECol = Cells(lRow, Columns.Count).End(xlToLeft).Column
            End If
        Next
      
         'Copy the REAL set of data
        Range(Cells(1, 1), Cells(BRow, ECol)).Copy
        Sheets(CSheet).Activate
         'Paste Every Thing
        Range("A1").PasteSpecial xlPasteAll
         'Paste Column Widths
        Range("A1").PasteSpecial xlPasteColumnWidths

        Sheets(OSheet).Activate
        For Each Pic In ActiveSheet.Pictures
            Pic.Copy
            Sheets(CSheet).Paste
            Sheets(CSheet).Pictures(Pic.Index).Top = Pic.Top
            Sheets(CSheet).Pictures(Pic.Index).Left = Pic.Left
        Next Pic
        Sheets(CSheet).Activate
      
         'Reset the variable for the next sheet
        BRow = 0
        ECol = 0
    Next WSheet
  
     ' Since, Excel will automatically replace the sheet references for you on your formulas,
     ' the below part puts them back.
     ' This is done with a simple replace, replacing _Delete with nothing
    For Each WSheet In Worksheets
        WSheet.Activate
        Cells.Replace "_Delete", ""
    Next WSheet
  
    'Roll through the sheets and delete the original fat sheets
    For Each WSheet In Worksheets
        If Not Len(Replace(WSheet.Name, "_Delete", "")) = Len(WSheet.Name) Then
            Application.DisplayAlerts = False
            WSheet.Delete
            Application.DisplayAlerts = True
        End If
    Next
End Sub








Anonymous said...

Thanks. It reduced my workbook file 10 times.

Anonymous said...

doesnt work here... maybe has to do with defining and copying names?

Anonymous said...

Right. Don't run this if your workbook uses names. The macro doesn't check for or copy to the new sheets. Instead, clear the cells manually using CTRl-SHIFT-DOWN to select the cells below your active sheets. Then right-click a selected-row and select 'Clear Contents.'

If you try running the VBA instead of clearing manually you'll end up with #REF errors anywhere your formula refers to a Name or Named-Range.

Anonymous said...

I tried this before reading the comments and agree: if you have Names in your worksheets, this macro won't work. On top of that, when I ran it on my 22MB file, it turned it into a 43MB file! With all the range names deleted! I'm still looking for a macro that will identify which of my 20 worksheets is causing the most problem in the workbook.
Cheers,
higrm

Excel Trick said...

This is really a great tip to reduce the size of Excel Work Sheets.
Initially I manually tried deleting the excess rows, but then I saw your macro. And I must say that it works like a charm.
Thanks for sharing a great tip. :)

Anonymous said...

try the vba code "activesheet.usedrange".

drop this into a macro that cycles through each worksheet. the process of calling the usedrange resets it.

this doesn't work if you have something (including formatting) in the supposedly blank cells