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: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
    Dim Pic As Object 
     'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
    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: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
        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: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
         '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