通过VBA删除多个工作表后，Excel文件的文件大小不会改变

Question

我使用 VBA 在 excel 中运行了一个模拟，它给了我大约 200 个工作表和模拟数据的摘要。现在，我认识到Excel的速度变慢了。因此，我删除了仅保留带有摘要的工作表的大部分工作表，以减小文件大小(目前约为 140mb(。不幸的是，文件大小没有显着变化。如何解决问题？

Answer 1

当我运行类似的场景时 - 我无法复制您的问题。 你如何删除工作表？ 这是我用来删除额外工作表的方法，并且在保存时正确修改了文件大小。

Sub DeleteSheets1()
'This macro will delete all sheets except 'sheet1'
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Sheet1" Then
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 2

按 Ctrl+Shift+End 并确认所选区域。 这是您所期望的还是范围远远超出了您的预期？ 选择您不需要/不需要的内容右侧的所有列，然后删除此范围。 从需要保留的位置向下选择所有行，然后删除此范围。 保存您的文件。 检查大小。 这是你期望看到的吗？

另外，请使用下面的VBA脚本重新计算每张纸的使用范围。

Sub ExcelDiet() 
Dim j               As Long 
Dim k               As Long 
Dim LastRow         As Long 
Dim LastCol         As Long 
Dim ColFormula      As Range 
Dim RowFormula      As Range 
Dim ColValue        As Range 
Dim RowValue        As Range 
Dim Shp             As Shape 
Dim ws              As Worksheet 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
On Error Resume Next 
For Each ws In Worksheets 
With ws 
'Find the last used cell with a formula and value
'Search by Columns and Rows
On Error Resume Next 
Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _ 
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) 
Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _ 
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) 
Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _ 
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious) 
Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _ 
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious) 
On Error GoTo 0 
'Determine the last column
If ColFormula Is Nothing Then 
LastCol = 0 
Else 
LastCol = ColFormula.Column 
End If 
If Not ColValue Is Nothing Then 
LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column) 
End If 
'Determine the last row
If RowFormula Is Nothing Then 
LastRow = 0 
Else 
LastRow = RowFormula.Row 
End If 
If Not RowValue Is Nothing Then 
LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row) 
End If 
'Determine if any shapes are beyond the last row and last column
For Each Shp In .Shapes 
j = 0 
k = 0 
On Error Resume Next 
j = Shp.TopLeftCell.Row 
k = Shp.TopLeftCell.Column 
On Error GoTo 0 
If j > 0 And k > 0 Then 
Do Until .Cells(j, k).Top > Shp.Top + Shp.Height 
j = j + 1 
Loop 
If j > LastRow Then 
LastRow = j 
End If 
Do Until .Cells(j, k).Left > Shp.Left + Shp.Width 
k = k + 1 
Loop 
If k > LastCol Then 
LastCol = k 
End If 
End If 
Next 
.Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count)).EntireColumn.Delete 
.Range("A" & LastRow + 1 & ":A" & .Rows.Count).EntireRow.Delete 
End With 
Next 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
End Sub