Excel vba delete empty rows saves to A1048576

Question

I had a hard drive failure, and did a clean install of Windows 10 ( 22H2 ) and Office 365 Business; Excel Version 2002 ( Build 12527.22286 Click-to-Run ). Upon opening up a 74-sheet xlsm file ( about 17.4 MBs ), I found formulas nearly all #VALUE.

The formulas included @ symbols, CSE {} formulas ( some not editable ), and a few _xlfn. Upon inspecting the sheet further, some cells were in Arial, others Calibri.

I wrote macro to remove all CSE, @, set the font back to Calibri, delete everything from empty cells, and delete past the last used row and column. Runtime is not an issue.

Upon running the macro setAllSheetsToDefaultsRemoveEmptyCells memory usage was exceeding 12 GB of RAM and Excel would crash. So I added in a Save. The Save fixed the RAM issue, but now, the file size exceeds 264MBs. Inspecting the huge file, some sheets go down to the last row of Excel, A1048576. I've searched, and all cell between last row and A1048576 are blank.

CTRL+END, does correctly go to the last column for each sheet. CSE's, @'s, _xlfn are removed, fonts are restored.

Things I've tried, adding in Save, increasing "Sleep time", Selecting cell A1, turning calculations on/off, and then decided I should post here.

This is complete, as I'm not sure where my RAM issue, or file size increase issue, is coming from.

Function getColLtr(colNum As Long) As String
 getColLtr = Split(Cells(1, colNum).address, "$")(1)
End Function

Function getLastColNum(ws As String) As Long
 getLastColNum = Sheets(ws).UsedRange.Columns.count
End Function

Function getLastColLtr(ws As String) As String
 getLastColLtr = getColLtr(Sheets(ws).UsedRange.Columns.count)
End Function

Function getLastRowOnSheet(ws As String) As Long
 With Sheets(ws)
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
     getLastRowOnSheet = .Cells.Find(what:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).row
  Else
   getLastRowOnSheet = 1
  End If
 End With
End Function

Sub TurnOffNotification()
 Application.DisplayAlerts = False
 ActiveSheet.DisplayPageBreaks = False
 Application.DisplayStatusBar = False
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
End Sub

Sub TurnOnNotification()
 Application.DisplayAlerts = True
 Application.DisplayStatusBar = True
 Application.EnableEvents = True
 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
End Sub


Sub setAllSheetsToDefaultsRemoveEmptyCells()
 Dim ws As Worksheet
 Dim currWs As String
 Dim lastColLtr As String
 Dim lastRowNum As Long
 Dim cColLtr As String
 Dim colRange As String
 Dim rng As Range
 Dim i As Long

 TurnOnNotification

 ThisWorkbook.Styles("Normal").Font.Name = "Calibri"
 ThisWorkbook.Styles("Normal").Font.Size = 11

 ActiveWorkbook.Save
 longSleepTime 1, currWs

 For Each ws In ActiveWorkbook.Worksheets
  currWs = LCase(Trim(ws.Name))
  Sheets(currWs).Range("A1").Select

  fixArrayFormulas currWs

  lastColLtr = LCase(Trim(getLastColLtr(currWs)))
  lastRowNum = getLastRowOnSheet(currWs)

  Sheets(currWs).Cells.Font.Size = 11
  ActiveWorkbook.Save
  longSleepTime 1, currWs

  For i = 1 To getLastColNum(currWs)
   cColLtr = getColLtr(i)
   colRange = cColLtr & "1:" & cColLtr & (lastRowNum + 1)
   If StrComp(currWs, "ranks", vbTextCompare) <> 0 Then
    On Error Resume Next
    With Range(colRange).SpecialCells(xlCellTypeBlanks)
     .ClearContents
     .ClearFormats
     .ClearComments
     .ClearContents
     .ClearHyperlinks
     .ClearNotes
     .Clear
    End With
    On Error GoTo -1
   Else
    If i <> 24 And i <> 26 Then
     On Error Resume Next
     With Range(colRange).SpecialCells(xlCellTypeBlanks)
      .ClearContents
      .ClearFormats
      .ClearComments
      .ClearContents
      .ClearHyperlinks
      .ClearNotes
      .Clear
     End With
     On Error GoTo -1
    End If
   End If
  Next ws

  longSleepTime 1, currWs
  clearColsFrom currWs, lastColLtr
  Sheets(currWs).Range("A1").Select

  longSleepTime 1, currWs
  clearRowsFrom currWs, lastRowNum
  Sheets(currWs).Range("A1").Select
  longSleepTime 1, currWs

  TurnOnNotification
  setDefaultFonts currWs
  TurnOnNotification
 Next

 longSleepTime 1, currWs
 ActiveWorkbook.Save

 longSleepTime 1, currWs
 Calculate
 TurnOnNotification
 Sheets("trends").Select
 MsgBox "Done.", vbOKOnly, "Finshed clearing blank cells."
End Sub


Sub fixArrayFormulas(ws As String)
 Dim rRange As Range, cell As Range
 Dim address As String
 Dim f As Variant, fnd As Variant, rplc As Variant

 fnd = "@"
 rplc = ""

 Sheets(ws).Activate
 Sheets(ws).Unprotect

 On Error Resume Next
 Sheets(ws).Cells.Replace what:=fnd, Replacement:=rplc, _
                          LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                          SearchFormat:=False, ReplaceFormat:=False

 fnd = "_xlfn."

 Sheets(ws).Cells.Replace what:=fnd, Replacement:=rplc, _
                          LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                          SearchFormat:=False, ReplaceFormat:=False

 Set rRange = Sheets(ws).UsedRange.SpecialCells(xlCellTypeFormulas)

 TurnOffNotification
 For Each cell In rRange
  If cell.HasArray Then
   f = Trim(CStr(cell.Formula))
   address = cell.address
   Sheets(ws).Range(address).Formula = f
  End If
 Next cell

 On Error GoTo -1
 longSleepTime 1, ws
End Sub

Sub setDefaultFonts(ws As String)
 Dim i As Long, j As Long
 Dim exceptArr() As String
 Dim wsName As String
 Dim foundExcept As Boolean

 ReDim exceptArr(2) As String
 exceptArr(0) = "tre"
 exceptArr(1) = "summary"
 exceptArr(2) = "100k"

 wsName = CStr(LCase(Trim(ws)))

 Sheets(wsName).Cells.Font.Name = "Calibri"
 Sheets(wsName).Cells.Font.Size = 11

 For i = 0 To UBound(exceptArr)

  foundExcept = False
  If Len(wsName) >= Len(exceptArr(i)) Then
    If InStr(1, wsName, exceptArr(i), vbTextCompare) > 0 Then
     foundExcept = True
    End If
  Else
   If InStr(1, exceptArr(i), wsName, vbTextCompare) > 0 Then
    foundExcept = True
   End If
  End If

  If foundExcept Then
   If InStr(1, wsName, "trends", vbTextCompare) > 0 Then
    Sheets(wsName).Range("A8:Q10").Font.Size = 9
    Sheets(wsName).Range("A12:S22").Font.Size = 9
   ElseIf InStr(1, wsName, "summ", vbTextCompare) > 0 Then
    Sheets(wsName).Cells.Font.Size = 10
   ElseIf InStr(1, wsName, "100k", vbTextCompare) > 0 Then
    Sheets(wsName).Range("B6:Q12").Font.Size = 8
   End If
  End If
 Next i
 longSleepTime 1, wsName
End Sub

Sub clearColsFrom(ws As String, lastColLtr As String)
 Dim fromColLtr As String
 fromColLtr = getColLtr(getColNum(lastColLtr) + 1)
 Sheets(ws).Range(fromColLtr & ":" & "XFD").Delete
End Sub

Sub clearRowsFrom(ws As String, lastRow As Long)
 Sheets(ws).Range("A" & (lastRow + 1) & ":A1048576").Delete
End Sub

Sub longSleepTime(Finish As Long, ByVal actSheet As String)
 TurnOnNotification

 If IsNull(actSheet) Then
  Calculate
 ElseIf actSheet = "" Then
  Calculate
 ElseIf (workSheetExists(actSheet)) Then
  Worksheets(actSheet).Calculate
 Else
  Calculate
 End If
 Application.Wait DateAdd("s", 1, Now)

 Dim t As Long
 Dim nSec As Long

 nSec = IIf(Finish < 4, 1, 1 + (Finish / 3))
 t = Timer()
 Do
  DoEvents
  If Abs(Timer() - t) > nSec Then
   Exit Do
  End If
 Loop

 t = Timer()
 Do
  If Abs(Timer() - t) > nSec Then
   Exit Do
  End If
 Loop

 t = Timer()
 If Application.CalculationState <> xlDone Then
  Do While Application.CalculationState <> xlDone
   DoEvents
    If Abs(Timer() - t) > nSec Then
     Exit Do
    End If
  Loop
 End If
 TurnOffNotification
End Sub

Update: Link to google sheets to download xlsx file. This is the 17.1 MB file. If you run the macro setAllSheetsToDefaultsRemoveEmptyCells. File size will increase to over 250MBs. To speed things up, you should be able to delete some of the 74 sheets if you choose.

Last sheet is ExcelMacros. Copy Col A into a VBA module, save as xlsm file.

https://docs.google.com/spreadsheets/d/1hQqOUbmZ6wrHKY8a68WYIwsiLdy7Apyu/edit?usp=sharing&ouid=113069209902618825802&rtpof=true&sd=true

Consider [avoiding Select](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) in your code. Also, consider checking the sizre of the used range on each sheet — cybernetic.nomad, Mar 28 '23 at 14:24
I've fixed a few files by manually deleting the empty rows. Click on the first empty row, press Ctrl + Shift + ↓. This should highlight all of the empty rows. Right click and Delete. You can do the same thing to the columns. — Toddleson, Mar 28 '23 at 14:44
By adjusting the font defaults etc you are essentially applying formatting which could be why Ctrl-END takes you past the end of your data. I usually delete the entire row in those instances — CHill60, Mar 28 '23 at 14:45
Side note: Cells filled using SEQUENCE command were sometimes detected as blank. However, the sheets with SEQUENCE did not experience the Last Row issue. — Uncl Scott, Mar 28 '23 at 14:45
@cybernetic.nomad, I know, but I'm not sure it's causing a RAM or file size issue. I added the selects as a desperate measure. — Uncl Scott, Mar 28 '23 at 14:49
@CHill60, Thank you. I'll remove the font, then try running it to see what happens ( with and without the saves ). I'll report back later tonight. — Uncl Scott, Mar 28 '23 at 14:52
@Toddleson, I designed the sheets, so Row 1 always has the most columns. Each sheet has different row counts. With the massive file, I could CTRL+SHIFT+Down on three sheets, before having to save, close, and reopen. More than 3-sheets, excel would crash and auto recover. — Uncl Scott, Mar 28 '23 at 14:54
If you open the huge file, make a small change in one cell and resave it, does the file size increase? — cybernetic.nomad, Mar 28 '23 at 15:05
@CHill60, so it's close, as commenting out the .font, made the file size drop from 268MB down to 258 MB. Good thought though. I'm kinda surprised though it's an 8 MB difference. — Uncl Scott, Mar 29 '23 at 03:44
@cybernetic.nomad, I made a small change to on a sheet with the row issue, and no change. I tried on a sheet without a row issue, and again no change :( — Uncl Scott, Mar 29 '23 at 03:45
I'm adding a comment to a link to google sheets. Last sheet is called ExcelMacros. Copy and paste column A into a vba module and save as xlsm file. In theory, you should be able to download > save as xslx file — Uncl Scott, Mar 29 '23 at 03:59
It's unlikely people will download a file from an unknown source (I certainly won't). Consider copying the used range (not all cells) of the problem sheet into a new sheet, then deleting the problem sheet — cybernetic.nomad, Mar 29 '23 at 14:33
@cybernetic.nomad, Fair enough. I got to thinking, is there a way to xlDown .Delete? Maybe it's that I hard coded the last row? — Uncl Scott, Mar 29 '23 at 16:15
https://stackoverflow.com/questions/11169445/find-last-used-cell-in-excel-vba/11169920#11169920 — cybernetic.nomad, Mar 29 '23 at 16:21

Excel vba delete empty rows saves to A1048576

0 Answers0