Excel Macro to Reduce File Size?

[brawnystaff]

Currently using Excel 2010 and also have Winzip installed on my computer. One "trick" I have learned to reduce Excel file size is to use Windows File Explorer to change the Excel file extension to a zip extension (xlsx to zip) and then "unzip" that file to a unique folder, as xlsx files are basically zip files of xlm files. After unzipping, I then re-zip the files using the Winzip program, and then rename the zip extension to xlsx, which opens fine in Excel. This process reduces the file size ~25%.

I was wondering if there is an Exel macro that can do the process above? The path to Winzip on my computer is C:\Program Files\WinZip\WINZIP64.EXE. However, I have another comptuer where the path is C:\Program Files\WinZip\WINZIP32.EXE, so it would need to take into account those two locations.

I know there are other technqiues to reduce file size, but this seems to work the best Thanks.

 

[Blade Hunter]

This is somewhat different to the answer you were expecting but before you play around with Zip, try this code on your book

Sub LipoSuction2()
'Written by Daniel Donoghue 18/8/2009
'The purpose of this code is to offer an alternative to the original Liposuction code written by JBeaucaire for the MrExcel forums www.mrexcel.com
Dim WS As Worksheet
Dim CurrentSheet As String
Dim OldSheet As String
Dim Col As Long
Dim R As Long
Dim BottomrRow As Long
Dim EndCol As Long
'Begin addition 6/4/2010 for request: Excel file with the size 20MB - Page 2
Dim Pic As Object
'End Addition 6/4/2010 for request: Excel file with the size 20MB - Page 2
For Each WS In Worksheets
    WS.Activate
    'Put the sheets in a variable to make it easy to go back and forth
    CurrentSheet = WS.Name
    'Rename the sheet to its name with TRMFAT at the end
    OldSheet = CurrentSheet & "TRMFAT"
    WS.Name = OldSheet
    'Add a new sheet and call it the original sheets name
    Sheets.Add
    ActiveSheet.Name = CurrentSheet
    Sheets(OldSheet).Activate
    'Find the bottom cell of data on each column and find the further row
    For Col = 1 To Columns.Count 'Find the REAL bottom row
        If Cells(Rows.Count, Col).End(xlUp).Row > BottomRow Then
            BottomRow = 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 R = 1 To BottomRow 'Find the REAL most right column
        If Cells(R, Columns.Count).End(xlToLeft).Column > EndCol Then
            EndCol = Cells(R, Columns.Count).End(xlToLeft).Column
        End If
    Next
    'Copy the REAL set of data
    Range(Cells(1, 1), Cells(BottomRow, EndCol)).Copy
    Sheets(CurrentSheet).Activate
    'Paste everything
    Range("A1").PasteSpecial xlPasteAll
    'Paste Column Widths
    Range("A1").PasteSpecial xlPasteColumnWidths
    'Begin addition 6/4/2010 for request: Excel file with the size 20MB - Page 2
    Sheets(OldSheet).Activate
    For Each Pic In ActiveSheet.Pictures
        Pic.Copy
        Sheets(CurrentSheet).Paste
        Sheets(CurrentSheet).Pictures(Pic.Index).Top = Pic.Top
        Sheets(CurrentSheet).Pictures(Pic.Index).Left = Pic.Left
    Next
    Sheets(CurrentSheet).Activate
    'End Addition 6/4/2010 for request: Excel file with the size 20MB - Page 2
    'Reset the variable for the next sheet
    BottomRow = 0
    EndCol = 0
Next
'Excel will automatically replace the sheet references for you on your formulas, the below part puts them back
'This is done with a simple reaplce, replacing TRMFAT with nothing
For Each WS In Worksheets
    WS.Activate
    Cells.Replace "TRMFAT", ""
Next
'Poll through the sheets and delete the original bloated sheets
For Each WS In Worksheets
    If Not Len(Replace(WS.Name, "TRMFAT", "")) = Len(WS.Name) Then
        Application.DisplayAlerts = False
        WS.Delete
        Application.DisplayAlerts = True
    End If
Next
End Sub

I never got round to adding the chart copy method but most ofther things copy across

Cheers

Dan