Large, Slow Excel Workbook

[dgavin]

I have a large Excel workbook (about 70,000KB) and it takes ages to load and is slow to operate.

Is there anyway of compressing it or making it run faster and not slow down the computer?

 

[ZVI]

Never mind..I found it and it screwed my workbook up terribly.

This Add-Ins not only resets the last used cell, but also remove something from the sheets.
More safe solution was offered by Just_Jon here:
http://www.mrexcel.com/forum/showthread.php?t=120831&page=2

 

[dave3009]

Appears as thought dispite Microsoft reporting no known issues it does have a bug!

I have used this without error for ages so this is totally new to me.

Create some data in the normal screen area, now run the xsformatcleaner. No problem -

In my version of XL07 if I go to the last useable cell XFD1048576 put any character, now run the xsformatcleaner - book gets wiped out that god it doesn't autosave.

 

[Jerryjaysr]

Not sure exactly- looked like a little kid went in and changed my column widths and moved some things around.

I may try it later on a more simplier workbook

 

[dave3009]

Oh It's done that to me before, try ZVI's option it seems safer

 

[ZVI]

I don’t think that mentioned Add-Ins has a bug
My message was that it deletes or may be clears all empty bottom & right cells including of those this formatting and may be something else. The code of this Add-In is protected, so my recommendation is in usage of the open source code to be aware what exactly could be happened.
Here is slightly improved code of Just_Jon, the original code was published on this link:
http://www.mrexcel.com/forum/showthread.php?t=120831&page=2

' Clearing of all worksheets in active workbook
' http://www.mrexcel.com/forum/showthread.php?t=120831&page=2
' Code of Just_Jon
' Minor modification has been applied by ZVI
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
  Dim ac

  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    ac = .Calculation: .Calculation = xlCalculationManual
  End With

  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
      
      ' > Modified by ZVI
      If LastCol < .Columns.Count Then
        With .Range(.Cells(1, LastCol + 1), .Cells(.Rows.Count, .Columns.Count))
          .Clear
          .EntireRow.RowHeight = ws.StandardHeight
        End With
      End If
      If LastRow < .Rows.Count Then
        With .Range(.Cells(LastRow + 1, 1), .Cells(.Rows.Count, .Columns.Count))
          .Clear
          .EntireColumn.ColumnWidth = ws.StandardWidth
        End With
      End If
      With .UsedRange: End With
      ' <
      
    End With
  Next

  With Application
    .Calculation = ac
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  
End Sub

Vladimir

 

[dave3009]

ZVI

If you have Excel 07 can you please test the addin once you put a 4 in XFD1048576 then run the code in my instance of Excel it completely wipes every page

The one that Just_Jon suggests may be fine although I haven't tested it yet

 

[ZVI]

ZVI

If you have Excel 07 can you please test the addin once you put a 4 in XFD1048576 then run the code in my instance of Excel it completely wipes every page

The one that Just_Jon suggests may be fine although I haven't tested it yet

Yes Dave, you have caught the bug of the MS Add-Ins!

I have found it out also in Excel 2003 writing something on the latest sheet cell and now confirm that it is definitly the bug of the XSFormatCleaner.xla Add-Ins.

On the same test the modified code of Just_Jon (see above) works correctly.

Regards,
Vladimir

 

[SusaninHouston]

Wow!

I tried this on a 'large, slow' Excel 2007 workbook of mine, and it KILLED all of my special formatting for a "huge" savings of 7 KB, so less than 1%...

Save a backup of your file first!

 

[ZVI]

I’ve posted the safe modification of the code in the thread Excel file huge, post #22.

It works in all versions of MS Excel, optionally switches off the chart's AutoScaleFontm, doesn’t kill your shapes and comments beyond the last cell, supports merged cells, supports protected sheets and informs about the size before and after processing.

For the case this is the copy of the code:

Sub MrExcelDiet()
' ZVI:2009-08-08 Active workbook excess formatting clearing
' Idea & original code of Just_Jon: http://www.mrexcel.com/forum/showthread.php?t=120831
' My first attempt of modification: http://www.mrexcel.com/forum/showthread.php?t=339144
  Const Title = "MrExcelDiet: Just_Jon's code modified by ZVI"
  Const vbTab2 = vbTab & vbTab
  Dim Wb As Workbook, Ws As Worksheet, LastCell As Range, Shp As Shape, Chrt As Chart
  Dim Prot As Boolean, ProtWarning As Boolean, DoCharts As Boolean
  Dim LastRow&, LastCol&, ShpLastRow&, ShpLastCol&, i&, ac, x
  Dim SheetsTotal&, SheetsCleared&, ChartsCleared&, SheetsProtSkipped&
  Dim FileNameTmp$, BytesInFileOld&, BytesInFileNew&
  ' Choose the clearing mode
  Set Wb = ActiveWorkbook
  x = MsgBox("Excess formatting clearing of " & Wb.Name & vbCr & vbCr & _
             "Apply full clearing?" & vbCr & vbCr & _
             "Yes" & vbTab & "- Full mode, including chart's AutoScaleFont=False" & vbCr & _
             "No" & vbTab & "- Medium mode, without charts processing" & vbCr & _
             "Cancel" & vbTab & "- Stop clearing & Exit", _
             vbInformation + vbYesNoCancel, _
             Title)
  If x = vbCancel Then Exit Sub
  DoCharts = (x = vbYes)
  ' Freeze on
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    ac = .Calculation: .Calculation = xlCalculationManual
  End With
  ' Calculate the old file size
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    FileNameTmp = .GetSpecialFolder(2) & "\" & Wb.Name & ".TMP"
    Wb.SaveCopyAs FileNameTmp
    BytesInFileOld = .GetFile(FileNameTmp).Size
  End With
  ' Processing in each worksheet
  ProtWarning = True
  SheetsTotal = Wb.Sheets.Count
  For Each Ws In Wb.Worksheets
    With Ws
      ' Clear an error flag
      Err.Clear
      ' Inform on processing status
      Application.StatusBar = "MrExcelDiet: processing of sheet " & Ws.Name
      ' Check protection
      Prot = .ProtectContents
      ' Try to unprotect without password
      If Prot Then .Unprotect ""
      If (Err <> 0 Or .ProtectContents) And ProtWarning Then
        SheetsProtSkipped = SheetsProtSkipped + 1
        x = MsgBox(Ws.Name & " is protected and will be skipped" & vbCr & vbCr & _
                   "Skip warning on protected sheets?" & vbCr & vbCr & _
                   "Yes" & vbTab & "- Skip warning, clear sheets silently" & vbCr & _
                   "No" & vbTab & "- Warning on each protected sheets" & vbCr & _
                   "Cancel" & vbTab & "- Stop clearing & Exit", _
                   vbExclamation + vbYesNoCancel, _
                   Title)
        ProtWarning = (x = vbNo)
        If x = vbCancel Then GoTo exit_
      Else
        ' Count processed worksheets
        SheetsCleared = SheetsCleared + 1
        ' Determine the last used cell with a formula or value or comment in Ws
        Set LastCell = GetLastCell(Ws)
        ' Determine the last column and last row
        If Not LastCell Is Nothing Then
          LastCol = LastCell.Column
          LastRow = LastCell.Row
        End If
        ' Determine if any merged cells are beyond the last row
        For Each x In Range(.Cells(LastRow, 1), .Cells(LastRow, LastCol))
          If x.MergeCells Then
            With x.MergeArea
              LastRow = Max(LastRow, .Rows(.Rows.Count).Row)
            End With
          End If
        Next
        ' Determine if any merged cells are beyond the last column
        For Each x In Range(.Cells(1, LastCol), .Cells(LastRow, LastCol))
          If x.MergeCells Then
            With x.MergeArea
              LastCol = Max(LastCol, .Columns(.Columns.Count).Column)
            End With
          End If
        Next
        ' Determine if any shapes are beyond the last row and last column
        ShpLastCol = LastCol
        ShpLastRow = LastRow
        For Each Shp In .Shapes
          ShpLastCol = Max(ShpLastCol, Shp.BottomRightCell.Column)
          ShpLastRow = Max(ShpLastRow, Shp.BottomRightCell.Row)
        Next
        ' Clear cells beyond the last column
        If LastCol < .Columns.Count Then
          With .Range(.Columns(LastCol + 1), .Columns(.Columns.Count))
            .Clear
            If LastCol >= ShpLastCol Then
              ' Set StandardWidth to columns which are beyond the vlast col
              .EntireColumn.ColumnWidth = Ws.StandardWidth
            ElseIf ShpLastCol < .Columns.Count Then
              ' Set StandardWidth to columns which are beyond the Shapes
              With .Range(.Columns(ShpLastCol + 1), .Columns(.Columns.Count))
                .EntireColumn.ColumnWidth = Ws.StandardWidth
              End With
            End If
          End With
        End If
        ' Clear cells beyond the last row
        If LastRow < .Rows.Count Then
          With .Range(.Rows(LastRow + 1), .Rows(.Rows.Count))
            .Clear
            If LastRow >= ShpLastRow Then
              ' Set StandardWidth to rows which are beyond the last row
              .EntireRow.RowHeight = Ws.StandardHeight
            ElseIf ShpLastRow < .Rows.Count Then
              ' Set StandardHeight to rows which are beyond the Shapes
              With .Range(.Rows(ShpLastRow + 1), .Rows(.Rows.Count))
                .EntireRow.RowHeight = Ws.StandardHeight
              End With
            End If
          End With
        End If
        ' Reset last cell position of the sheet
        With .UsedRange: End With
        ' Protect the sheet if it was unprotected
        If Prot Then .Protect
      End If
      ' Apply setting to worksheet's charts: ChartArea.AutoScaleFont = False
      If DoCharts Then
        For i = 1 To .ChartObjects.Count
          Application.StatusBar = "MrExcelDiet: processing of chart " & .ChartObjects(i).Name
          .ChartObjects(i).Chart.ChartArea.AutoScaleFont = False
          ChartsCleared = ChartsCleared + 1
        Next
      End If
    End With
  Next
  ' Apply setting to workbook's charts: ChartArea.AutoScaleFont = False
  If DoCharts Then
    With Wb
      For i = 1 To .Charts.Count
        ' Clear an error flag
        Err.Clear
        ' Inform on processing status
        Application.StatusBar = "MrExcelDiet: processing of chart " & .Charts(i).Name
        ' Check chart sheet protection
        Prot = .Charts(i).ProtectContents
        ' Try to unprotect chart sheet without password
        If Prot Then .Charts(i).Unprotect ""
        If (Err <> 0 Or .Charts(i).ProtectContents) And ProtWarning Then
          SheetsProtSkipped = SheetsProtSkipped + 1
          x = MsgBox(Ws.Name & " is protected and will be skipped" & vbCr & vbCr & _
                     "Skip warning on protected sheets?" & vbCr & vbCr & _
                     "Yes" & vbTab & "- Skip warning, clear sheets silently" & vbCr & _
                     "No" & vbTab & "- Warning on each protected sheets" & vbCr & _
                     "Cancel" & vbTab & "- Stop clearing & Exit", _
                     vbExclamation + vbYesNoCancel, _
                     Title)
          ProtWarning = (x = vbNo)
          If x = vbCancel Then GoTo exit_
        Else
          ' Set AutoScaleFont = False for chart sheet
          .Charts(i).ChartArea.AutoScaleFont = False
          SheetsCleared = SheetsCleared + 1
          ChartsCleared = ChartsCleared + 1
          ' Protect the chart sheet if it was unprotected
          If Prot Then .Charts(i).Protect
        End If
      Next
    End With
  End If
exit_:
  ' Calculate the new file size
  Wb.SaveCopyAs FileNameTmp
  BytesInFileNew = CreateObject("Scripting.FileSystemObject").GetFile(FileNameTmp).Size
  Kill FileNameTmp
  ' Freeze off
  With Application
    .Calculation = ac
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  ' Report on results
  Application.StatusBar = False
  x = MsgBox("Statistics of excess formatting clearing" & vbLf & vbLf & _
             "Workbook:" & vbTab & ActiveWorkbook.Name & "'" & vbLf & _
             "Sheets total:" & vbTab2 & SheetsTotal & vbLf & _
             "Sheets cleared:" & vbTab2 & SheetsCleared & vbLf & _
             "Protected sheets skipped: " & vbTab & SheetsProtSkipped & vbLf & _
             "Other sheets skipped:" & vbTab & SheetsTotal - SheetsCleared - SheetsProtSkipped & vbLf & _
             "Charts cleared:" & vbTab2 & ChartsCleared & vbLf & _
             "File size old:" & vbTab & Format(BytesInFileOld, "# ### ##0") & " Bytes" & vbLf & _
             "File size new:" & vbTab & Format(BytesInFileNew, "# ### ##0") & " Bytes" & vbLf & _
             vbLf & _
             "Save the cleared workbook to keep the changes?" & vbLf & _
             "Yes" & vbTab & "- Save & Exit" & vbLf & _
             "No" & vbTab & "- Exit without saving, cleared", _
             vbInformation + vbYesNo + IIf(BytesInFileNew < BytesInFileOld, vbDefaultButton1, vbDefaultButton2), _
             Title)
  If x = vbYes Then Wb.Save
End Sub

' ZVI:2009-02-02 Get last cell within values/formulas/comments of sheet Sh
' Auto-filtered & hidden rows/columns are also calculated without ShowAllData
' ActiveSheet is used if optional Sh is missing
' If VisibleOnly=True then only visible cells are searched
Function GetLastCell(Optional Sh As Worksheet, Optional VisibleOnly As Boolean) As Range
  Dim SpecCells(), Rng As Range, r&, c&, x, a
  SpecCells = Array(xlCellTypeConstants, xlCellTypeFormulas, xlCellTypeComments)
  On Error Resume Next
  If Sh Is Nothing Then Set Sh = ActiveSheet
  Set Rng = Sh.UsedRange
  If VisibleOnly Then Set Rng = Rng.SpecialCells(xlCellTypeVisible)
  For Each x In SpecCells
    For Each a In Rng.SpecialCells(x).Areas
      With a.Cells(a.Rows.Count, a.Columns.Count)
        c = Max(c, .Column)
        r = Max(r, .Row)
      End With
    Next
  Next
  If r * c <> 0 Then Set GetLastCell = Sh.Cells(r, c)
End Function

' Aux function: max value of arguments
Private Function Max(ParamArray Values())
  Dim x
  For Each x In Values
    If x > Max Then Max = x
  Next
End Function

Regards,
Vladimir

 

[SusaninHouston]

Thanks for posting that Vladimir --

That version appears to have kept all of my formatting, and netted me a 25K improvement -- but still only a 0.6% shrinkage. Guess my file wasn't very bloated...