Hi Guys, this didn't work for us in Excel 2007. I have written an alternative, I hope it is useful to someone.
You can change TRMFAT to whatever you want, just make sure you replace it everywhere.
The problem you will find with this code is if your sheet names are as long as the limit. We have not encountered this but you could easily set up a bunch of variables and do it that way.
Rich (BB code):
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
This code will basically rename your sheet to have TRMFAT after it and Excel will auto update referencing formulas. It will then create a new sheet with the name of the original sheet and paste the data and column widths in to it before moving on to the next sheet.
Once it has done all sheets it looks through the new sheets and replaces TRMFAT in all the formulas with "", this will point the formulas to the NEW copies of the sheets.
Finally the original sheets are deleted.
Do make sure you test this on a
COPY first.
This relies on the last cell and row of data actually having real data. Maybe someone on here can improve on the code to ensure that there really is data in it and not some random unresolved formula.
Cheers
Dan
.
