修剪所有空格式的Excel文件的最可靠有效的方法是什么？
我认为Used Range是具有可见数据和对象的所有单元格，不包括Comments。
可靠性方面：
保留所有工作表上的对象：图表，数据透视表和列表对象（数据表）
删除所有空白单元格，使用旧格式或空字符串生成＆＃34; false＆＃34;使用范围
解决方案还应删除所有无效的名称（包含字符串＆＃34; #REF！＆＃34;）
此解决方案的覆盖范围超过Microsoft在此页面上提供的解决方案
{+ 3}}
答案 0 :(得分：0)
我提供自己的尝试来涵盖这些要求，作为参考
将代码粘贴到新的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