Excel vba删除空行保存到A1048576

Question

我的硬盘出现故障，并全新安装了 Windows 10 ( 22H2 ) 和 Office 365 商业版； Excel 版本 2002（内部版本 12527.22286 即点即用）。打开一个 74 页 xlsm 文件（约 17.4 MB）后，我发现公式几乎都是#VALUE。

公式包括@符号、CSE {}公式（有些不可编辑）和一些_xlfn。进一步检查纸张后，一些电池是 Arial，其他电池是 Calibri。

我写了宏来删除所有 CSE，@，将字体设置回 Calibri，删除空单元格中的所有内容，并删除最后使用的行和列。 运行时不是问题.

运行宏 setAllSheetsToDefaultsRemoveEmptyCells 时，内存使用量超过 12 GB RAM，Excel 会崩溃。所以我添加了一个保存。保存修复了 RAM 问题，但现在文件大小超过 264MB。检查巨大的文件，some 表向下到 Excel 的最后一行，A1048576。我已经搜索过了，最后一行和 A1048576 之间的所有单元格都是空白的。

CTRL+END，确实正确转到每张纸的最后一列。 CSE、@、_xlfn 已删除，字体已恢复。

我尝试过的事情，添加保存，增加“睡眠时间”，选择单元格 A1，打开/关闭计算，然后决定我应该在这里发布。

这是完整的，因为我不确定我的 RAM 问题或文件大小增加问题是从哪里来的。

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

更新：链接到谷歌表格以下载 xlsx 文件

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