Question

为了减少60MB的excel文件，我删除了一半标签，以及其余标签上的许多公式。结果没有让整个文件大小变得更糟。也许（如访问中）有一个函数/插件/？哪个会压缩或恢复空间？我试图将标签导出到一个新文件，但是，大多数标签都有表格，因此是不可能的。

顺便说一下，该文件已经是.XLSB格式。谢谢， -R

Answer 1

这是我多年前写的吸脂代码，它会做公式，文字和图片，目前不做图表，但你可以看到它如何处理图片并轻松添加。

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

删除excel标签不会减小文件大小

1 个答案: