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
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
'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