Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement