Option Explicit' 主程序：选择文件并优化Sub OptimizeSelectedWorkbook()    Dim filePath As Variant    Dim targetWb As Workbook    Dim originalSize As Long    Dim backupPath As String    Dim answer As VbMsgBoxResult    ' 让用户选文件    filePath = Application.GetOpenFilename( _        FileFilter:="Excel文件 (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", _        Title:="请选择要优化的Excel文件", _        MultiSelect:=False)    If filePath = False Then Exit Sub    ' 检查文件是否已打开    On Error Resume Next    Set targetWb = Workbooks(filePath)    On Error GoTo 0    If Not targetWb Is Nothing Then        MsgBox "文件 '" & targetWb.Name & "' 已在Excel中打开，请先关闭。", vbExclamation        Exit Sub    End If    ' 加速设置    Application.ScreenUpdating = False    Application.Calculation = xlCalculationManual    Application.EnableEvents = False    ' 打开文件    Set targetWb = Workbooks.Open(filePath, UpdateLinks:=0, ReadOnly:=False)    originalSize = FileLen(filePath)    ' 询问备份    answer = MsgBox("是否在优化前创建备份？", vbYesNo + vbQuestion, "备份提示")    If answer = vbYes Then        backupPath = CreateBackup(targetWb)        MsgBox "备份已创建：" & vbCrLf & backupPath, vbInformation    End If    ' 执行优化    OptimizeWorkbook targetWb, originalSize    ' 关闭文件（已保存）    targetWb.Close SaveChanges:=False    ' 恢复设置    Application.ScreenUpdating = True    Application.Calculation = xlCalculationAutomatic    Application.EnableEvents = True    MsgBox "优化完成！", vbInformationEnd Sub' 创建备份Function CreateBackup(wb As Workbook) As String    Dim folder As String, nameOnly As String, ext As String    folder = wb.Path & Application.PathSeparator    nameOnly = Left(wb.Name, InStrRev(wb.Name, ".") - 1)    ext = Mid(wb.Name, InStrRev(wb.Name, "."))    CreateBackup = folder & nameOnly & "_备份_" & Format(Now, "yyyymmdd_hhmmss") & ext    wb.SaveCopyAs CreateBackupEnd Function' 核心优化Sub OptimizeWorkbook(wb As Workbook, originalSize As Long)    Dim ws As Worksheet, lastCell As Range, shp As Shape, pt As PivotTable    Dim nm As Name, sty As Style, i As Long    Dim startTime As Double, newSize As Long    startTime = Timer    On Error Resume Next    For Each ws In wb.Worksheets        Set lastCell = ws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)        If Not lastCell Is Nothing Then            If lastCell.Column < ws.Columns.Count Then                ws.Range(ws.Cells(1, lastCell.Column + 1), ws.Cells(ws.Rows.Count, ws.Columns.Count)).Delete            End If            If lastCell.Row < ws.Rows.Count Then                ws.Range(ws.Cells(lastCell.Row + 1, 1), ws.Cells(ws.Rows.Count, ws.Columns.Count)).Delete            End If        End If        Set lastCell = ws.UsedRange    Next ws    For Each nm In wb.Names        If InStr(1, nm.RefersTo, "#REF!", vbTextCompare) > 0 Then nm.Delete    Next nm    Application.CutCopyMode = False    Application.DisplayAlerts = False    For Each ws In wb.Worksheets        If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then ws.Delete    Next ws    Application.DisplayAlerts = True    For Each ws In wb.Worksheets        For i = ws.Shapes.Count To 1 Step -1            Set shp = ws.Shapes(i)            If shp.Visible = msoFalse Then                shp.Delete            ElseIf shp.Top > ws.UsedRange.Height + 500 Or shp.Left > ws.UsedRange.Width + 500 Then                shp.Delete            ElseIf shp.Height = 0 Or shp.Width = 0 Then                shp.Delete            ElseIf shp.Type <> msoPicture And shp.Fill.Visible = msoFalse And shp.Line.Visible = msoFalse Then                shp.Delete            End If        Next i    Next ws    For Each ws In wb.Worksheets        For Each pt In ws.PivotTables            pt.PivotCache.MissingItemsLimit = xlMissingItemsNone            pt.PivotCache.Refresh        Next pt    Next ws        For Each sty In wb.Styles        If Not sty.BuiltIn Then            On Error Resume Next            If Not sty.InUse Then sty.Delete            On Error GoTo 0        End If    Next sty    On Error GoTo 0    wb.Save    newSize = FileLen(wb.FullName)    MsgBox "✅ 优化完成！" & vbCrLf & _           "原始大小: " & Format(originalSize / 1024, "#,##0.0") & " KB" & vbCrLf & _           "当前大小: " & Format(newSize / 1024, "#,##0.0") & " KB" & vbCrLf & _           "节省: " & Format((originalSize - newSize) / 1024, "#,##0.0") & " KB (" & _           Format((originalSize - newSize) / originalSize, "0.0%") & ")" & vbCrLf & _           "耗时: " & Format(Timer - startTime, "0.0") & " 秒", _           vbInformation, "减肥报告"End Sub

代码是干啥的？简单说

• • 选文件：弹出对话框，你选哪个Excel，它就优化哪个。
• • 自动备份：在原文件同文件夹生成一个带时间戳的副本，防止意外。
• • 七步瘦身：
1. 1. 删掉所有工作表里多余的行和列（只保留有数据的区域）。
2. 2. 删除失效的名称（比如引用#REF!的）。
3. 3. 清空剪贴板。
4. 4. 删除完全空白的无用工作表。
5. 5. 清除隐藏的、透明的、尺寸为零的、飞出屏幕的图形对象——这些是卡顿元凶。
6. 6. 清理数据透视表缓存，减小体积。
7. 7. 删除没用的自定义样式。
• • 出报告：告诉你瘦了多少，花了多久。

注意

• • 代码会删除完全空白的工作表。
• • 图片默认只删隐藏/透明的，正常图片不动。如果想全删，可以自己改第5步条件。
• • 运行前建议先备份（代码已提供选项）。

快试试你的Excel能瘦多少斤吧！