Размер файла Excel не изменяется после удаления нескольких таблиц через VBA

Question

Я запустил симуляцию в Excel с VBA, которая вернула мне около 200 листов и сводку данных симуляции. Теперь я признаю, что скорость Excel стала медленнее. Таким образом, я удаляю большую часть рабочих листов, которые остаются только для рабочих листов со сводкой, чтобы уменьшить размер файла (который в настоящее время составляет около 140 МБ). К сожалению, размер файла существенно не изменился. Как я могу решить проблему?

Answer 1

Нажмите 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 

Answer 2

Когда я запускаю аналогичный сценарий - я не могу продублировать вашу проблему. Как вы удаляете листы? Это то, что я использую для удаления лишних листов, и размер файла корректно изменяется при сохранении.

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