如何清理工作簿并重置所有工作表上最后使用的单元格
什么是最可靠，最有效的方式来修剪空格式的Excel文件的所有表格？
我认为使用范围是包含可见数据和对象的所有单元，不包括注释。
可靠性方面：
- 保留所有表单上的所有可见数据（使用格式）和公式
-
保留所有图纸上的对象：图表，数据透视表和列表对象（数据表）
- 清理后，graphics保持完全相同的位置，大小和所有其他属性
-
删除旧格式的空白单元格或空string，生成一个“错误”使用范围
- 这些可以是之前使用的单元格，但是其数据已被删除
- 无效的公式，或不可见的字符，如未修剪的string或回车
-
解决scheme还应该删除所有无效的名称（包含string“#REF！”）
- 清除所有工作表上的条件格式化规则，删除相同列的重复规则
- 清除不受密码保护或保护的工作簿和工作表上的多余格式
-
这个解决scheme的覆盖范围比Microsoft提供的覆盖范围更广
-
如何重置Excel中的最后一个单元格
-
此答案中的Excel加载项中的代码
-
作为参考，我提供了自己的尝试来涵盖这些要求
将代码粘贴到新的VBA模块中并运行第一个过程（trimXL）
。
Option Explicit Private pb01 As Boolean, pb02 As Boolean 'protected attribs of WB & WS Private ps01 As Boolean, ps02 As Boolean, ps03 As Boolean, ps04 As Boolean Private ps05 As Boolean, ps06 As Boolean, ps07 As Boolean, ps08 As Boolean Private ps09 As Boolean, ps10 As Boolean, ps11 As Boolean, ps12 As Boolean Private ps13 As Boolean, ps14 As Boolean, ps15 As Boolean, ps16 As Boolean Private isWBProtected As Boolean Private shapeInfo As Object Public Function trimXL() As Boolean Dim wb As Workbook, ws As Worksheet, sCnt As Long, shapesOnWS As Long Dim lastCel As Range, urAll As Range, thisActWS As Worksheet, isGo As Boolean Dim lrAll As Long, lcAll As Long, lrDat As Long, lcDat As Long, msg As String Dim emptyRows As Range, emptyCols As Range, sz1 As Single, sz2 As Single enableXL False Set wb = ThisWorkbook If wbIsReady(wb) Then Set thisActWS = wb.ActiveSheet removeInvalidNames sz1 = FileLen(wb.FullName) / 1024 For Each ws In wb.Worksheets isGo = IIf(isWBProtected, canUnprotectWs(ws), True) If isGo Then Set urAll = ws.UsedRange lrAll = urAll.Rows.Count + urAll.Row - 1 lcAll = urAll.Columns.Count + urAll.Column - 1 If 0 Then unhideRows ws, urAll removeXLErrors ws.UsedRange trimWhiteSpaces ws Set shapeInfo = newDictionary shapesOnWS = persistShapesInfo(ws) trimListObjects ws Set lastCel = GetMaxCell(urAll) lrDat = lastCel.Row lcDat = lastCel.Column Set emptyRows = ws.Range(ws.Cells(lrDat + 1, 1), ws.Cells(lrAll + 1, 1)) Set emptyCols = ws.Range(ws.Cells(1, lcDat + 1), ws.Cells(1, lcAll + 1)) 'setStandardSize ws, emptyRows, emptyCols If (lrDat = 1 And lcDat = 1) Or (lrAll <> lrDat Or lcAll <> lcDat) Then If lrDat = 1 And lcDat = 1 And Len(lastCel.Value2) = 0 Then urAll.EntireRow.Delete If lrAll <> lrDat Or lcAll <> lcDat Then sCnt = sCnt + 1 Else If lrAll <> lrDat Or lcAll <> lcDat Then If lrAll <> lrDat Then emptyRows.EntireRow.Delete If lcAll <> lcDat Then emptyCols.EntireColumn.Delete sCnt = sCnt + 1 End If End If End If If shapesOnWS > 0 Then resetShapesInfo ws 'resetConditionalFormatting If isWBProtected Then protectWs ws End If Next activateFirstCell ws thisActWS.Activate If isWBProtected Then protectWB wb sz2 = FileLen(wb.FullName) / 1024 'wb.Save Set thisActWS = Nothing Set shapeInfo = Nothing End If enableXL msg = msg & " File '" & wb.Name & "' cleaned" & vbNewLine & vbNewLine msg = msg & " Size" & vbTab & "Before: " & vbTab & sz1 & " Kb" & vbNewLine msg = msg & vbTab & " After: " & vbTab & sz2 & " Kb" & vbNewLine & vbNewLine msg = msg & vbTab & "Trimmed Sheets" & vbTab & sCnt & vbTab & vbNewLine & vbNewLine MsgBox msg, vbInformation, " Trim Completed: """ & wb.Name & """" End Function 'Sheet Functions ----------------------------------------------------------------------- Private Sub activateFirstCell(ByRef ws As Worksheet) If ws Is Nothing Then Set ws = ThisWorkbook.ActiveSheet Application.Goto ws.Cells(1), True 'ws.Activate: ws.Cells(1).Activate End Sub Private Sub setStandardSize(ByRef ws As Worksheet, ByRef eRows As Range, eCols As Range) eRows.EntireColumn.ColumnWidth = ws.StandardWidth eCols.EntireColumn.ColumnWidth = ws.StandardWidth eRows.EntireRow.RowHeight = ws.StandardHeight eCols.EntireRow.RowHeight = ws.StandardHeight End Sub Public Sub unhideRows(ByRef ws As Worksheet, ByRef rng As Range) If ws Is Nothing Then Set ws = ThisWorkbook.ActiveSheet If rng Is Nothing Then Set rng = ws.UsedRange If Not ws.AutoFilter Is Nothing Then With ws.AutoFilter If .FilterMode Then If .Filters.Count = 1 Then rng.AutoFilter End With End If rng.Rows.EntireRow.Hidden = False rng.Columns.EntireColumn.Hidden = False End Sub Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range 'It returns the last cell of range with data, or A1 if Worksheet is empty Const NONEMPTY As String = "*" Dim lRow As Range, lCol As Range If rng Is Nothing Then Set rng = Application.ThisWorkbook.ActiveSheet.UsedRange If WorksheetFunction.CountA(rng) = 0 Then Set GetMaxCell = rng.Parent.Cells(1, 1) Else With rng Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ after:=.Cells(1, 1), _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows) Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _ after:=.Cells(1, 1), _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByColumns) Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column) End With End If End Function Public Sub trimWhiteSpaces(ByRef ws As Worksheet) 'Blanks ---------------------------- Dim i As Byte With ws.UsedRange For i = 1 To 10 .Replace What:=Space(i), Replacement:=vbNullString, LookAt:=xlWhole Next .Replace What:=vbTab, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbCrLf, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbCr, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbLf, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbNewLine, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbNullChar, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbBack, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbFormFeed, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbVerticalTab, Replacement:=vbNullString, LookAt:=xlWhole .Replace What:=vbObjectError, Replacement:=vbNullString, LookAt:=xlWhole End With End Sub Public Sub trimListObjects(ByRef ws As Worksheet) 'tables Dim tbl As ListObject, lastCel As Range, lrDat As Long, lcDat As Long For Each tbl In ws.ListObjects With tbl lcDat = .ListColumns.Count If .Range.Count <> (.ListRows.Count * lcDat) Then Set lastCel = GetMaxCell(.Range) lrDat = lastCel.Row - .Range.Row + 1 If lrDat = 1 Then .Delete Else .Resize .Range.Resize(lrDat + 1, lcDat) End If End With Next End Sub Public Sub removeXLErrors(ByRef ur As Range) 'All errors ---------------------------- Dim i As Byte, xlError() As String On Error Resume Next ur.SpecialCells(xlCellTypeFormulas, xlErrors).Clear If 0 Then ReDim xlError(6) xlError(0) = "#DIV/0!" 'Excel.XlCVError.xlErrDiv0 = 2007 => #DIV/0! xlError(1) = "#N/A" 'Excel.XlCVError.xlErrNA = 2042 => #N/A xlError(2) = "#NAME?" 'Excel.XlCVError.xlErrName = 2029 => #NAME? xlError(3) = "#NULL" 'Excel.XlCVError.xlErrNull = 2000 => #NULL xlError(4) = "#NUM!" 'Excel.XlCVError.xlErrNum = 2036 => #NUM! xlError(5) = "#REF" 'Excel.XlCVError.xlErrRef = 2023 => #REF xlError(6) = "#VALUE!" 'Excel.XlCVError.xlErrValue = 2015 => #VALUE! 'VBA.Conversion.CVErr 1 / 0 'Public Const EXCEL_ERROR As String = "#N/A" For i = 0 To 6 ur.Replace What:=xlError(i), Replacement:=vbNullString, LookAt:=xlWhole Next End If End Sub Public Sub resetConditionalFormatting(Optional ByRef rng As Range = Nothing) Const F_ROW As Long = 2 Dim ws As Worksheet, ur As Range, maxCol As Long, maxRow As Long, thisCol As Long Dim colRng As Range, fcCol As Range, fcCount As Long, fcAdr As String If rng Is Nothing Then Set rng = Application.ThisWorkbook.ActiveSheet.UsedRange Set ws = ThisWorkbook.ActiveSheet Set ur = ws.UsedRange maxRow = ur.Rows.Count maxCol = ur.Columns.Count For Each colRng In ws.Columns If colRng.Column > maxCol Then Exit For thisCol = thisCol + 1 Set fcCol = ws.Range(ws.Cells(F_ROW, thisCol), ws.Cells(maxRow, thisCol)) With colRng.FormatConditions If .Count > 0 Then fcCount = 1 fcAdr = .Item(fcCount).AppliesTo.Address While fcCount <= .Count If .Item(fcCount).AppliesTo.Address = fcAdr Then .Item(fcCount).ModifyAppliesToRange fcCol fcCount = fcCount + 1 Else On Error Resume Next .Item(fcCount).Delete End If Wend End If End With Next End Sub 'Workbook Functions -------------------------------------------------------------------- Public Sub removeInvalidNames() Dim itm As Name With ThisWorkbook If .Names.Count > 0 Then On Error Resume Next Err.Clear For Each itm In .Names If InStr(itm.RefersTo, "#REF!") > 0 Then itm.Delete Next End If 'xlResetSettings .Saved = True End With End Sub 'Shape Functions ----------------------------------------------------------------------- Public Function newDictionary(Optional ByRef dictObj As Object, _ Optional ByVal caseSensitive As Boolean = False) As Object If Not dictObj Is Nothing Then Set dictObj = Nothing 'Set dictionaryObject = New Dictionary Set dictObj = CreateObject("Scripting.Dictionary") dictObj.CompareMode = IIf(caseSensitive, vbBinaryCompare, vbTextCompare) Set newDictionary = dictObj End Function Private Function persistShapesInfo(ByRef ws As Worksheet) As Long Dim sh As Shape, totalShapes As Long For Each sh In ws.Shapes If Not sh.Type = msoComment Then With sh shapeInfo(.Name) = .Top & "|" & .Left & "|" & .Height & "|" & .Width shapeInfo(.Name) = shapeInfo(.Name) & "|" & .Placement .Placement = xlFreeFloating End With totalShapes = totalShapes + 1 End If Next persistShapesInfo = totalShapes End Function Private Sub resetShapesInfo(ByRef ws As Worksheet) Dim sh As Variant, shInfo As Variant For Each sh In shapeInfo shInfo = Split(shapeInfo(sh), "|") With ws.Shapes(sh) .Top = shInfo(0) .Left = shInfo(1) .Height = shInfo(2) .Width = shInfo(3) .Placement = shInfo(4) End With Next End Sub 'Excel Functions ----------------------------------------------------------------------- Public Sub enableXL(Optional ByVal opt As Boolean = True) With Application .Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual) .DisplayAlerts = opt .DisplayStatusBar = opt .EnableAnimations = opt .EnableEvents = opt .ScreenUpdating = opt End With enableWS , opt End Sub Public Sub enableWS(Optional ByVal ws As Worksheet, Optional ByVal opt As Boolean =True) If ws Is Nothing Then For Each ws In Application.ActiveWorkbook.Sheets setWS ws, opt Next Else setWS ws, opt End If End Sub Private Sub setWS(ByVal ws As Worksheet, Optional ByVal opt As Boolean = True) With ws .DisplayPageBreaks = False .EnableCalculation = opt .EnableFormatConditionsCalculation = opt .EnablePivotTable = opt End With End Sub Public Sub xlResetSettings() 'default Excel settings With Application .Calculation = xlCalculationAutomatic .DisplayAlerts = True .DisplayStatusBar = True .EnableAnimations = False .EnableEvents = True .ScreenUpdating = True Dim sh As Worksheet For Each sh In Application.ActiveWorkbook.Sheets With sh .DisplayPageBreaks = False .EnableCalculation = True .EnableFormatConditionsCalculation = True .EnablePivotTable = True End With Next End With End Sub 'Protection Functions ------------------------------------------------------------------ Private Function wbIsReady(ByRef wb As Workbook) As Boolean isWBProtected = wbIsProtected(wb) wbIsReady = canUnprotectWb(wb) End Function Private Function wbIsProtected(ByRef wb As Workbook) As Boolean Dim hasPassword As Boolean, ws As Worksheet If Not wb.ReadOnly Then pb01 = wb.ProtectStructure pb02 = wb.ProtectWindows hasPassword = pb01 Or pb02 For Each ws In wb.Worksheets hasPassword = hasPassword Or wsIsProtected(ws) If hasPassword Then Exit For Next End If wbIsProtected = hasPassword End Function Private Function wsIsProtected(ByRef ws As Worksheet) As Boolean With ws ps01 = .ProtectContents ps02 = .ProtectDrawingObjects With .Protection ps03 = .AllowDeletingColumns ps04 = .AllowDeletingRows ps05 = .AllowEditRanges.Count > 0 ps06 = .AllowFiltering ps07 = .AllowFormattingCells ps08 = .AllowFormattingColumns: ps09 = .AllowFormattingRows ps10 = .AllowInsertingColumns ps11 = .AllowInsertingHyperlinks ps12 = .AllowInsertingRows ps13 = .AllowSorting ps14 = .AllowUsingPivotTables End With ps15 = .ProtectionMode ps16 = .ProtectScenarios End With wsIsProtected = ps01 Or ps02 Or ps03 Or ps04 Or ps05 Or ps06 Or ps07 Or ps08 Or _ ps09 Or ps10 Or ps11 Or ps12 Or ps13 Or ps14 Or ps15 Or ps16 End Function Private Sub protectWB(ByRef wb As Workbook) If Not wb.ReadOnly Then wb.Protect vbNullString, pb01, pb02 End Sub Private Sub protectWs(ByRef ws As Worksheet) ws.Protect vbNullString, ps02, ps01, ps16, True, ps07, ps08, _ ps09, ps10, ps12, ps11, ps03, ps04, ps13, ps06, ps14 End Sub Private Function canUnprotectWb(ByRef wb As Workbook) As Boolean Dim hasPassword As Boolean hasPassword = True On Error Resume Next wb.Unprotect vbNullString If Err.Number = 1004 Then Err.Clear hasPassword = True End If canUnprotectWb = hasPassword End Function Private Function canUnprotectWs(ByRef ws As Worksheet) As Boolean Dim hasPassword As Boolean hasPassword = True On Error Resume Next ws.Unprotect vbNullString If Err.Number = 1004 Then Err.Clear hasPassword = False End If canUnprotectWs = hasPassword End Function 在这个SO答案中有关清理条件格式规则的更多细节