当我运行代码时，只有一个工作表会更新，例如苹果.其他3个工作表未更新.我该如何解决这个问题

Question

当我运行代码时，只有一个工作表会更新，例如Apple。其他3个工作表未更新。代码试图将工作表中的零值更改为空白。代码在整个宏中运行，但工作表Orange、Grape和Pear没有更新。我该如何解决这个问题？

Sub ReturnZerosAsBlanks()
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'Declare variables and objects'
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'

'Objects'
Dim wbk As Workbook
Dim wsApple As Worksheet
Dim wsOrange As Worksheet
Dim wsGrape As Worksheet
Dim wsPear As Worksheet

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'Define variables and objects'
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'set workbooks and worksheets'
Set wbk = ThisWorkbook
Set wsApple = wbk.Sheets("Apple")
Set wsOrange = wbk.Sheets("Orange")
Set wsGrape = wbk.Sheets("Grape")
Set wsPear = wbk.Sheets("Pear")

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'Application settings'
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'Remove zeros from blank linked cells
'Column AA:AB in tab Apple
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'

Dim Rng1 As Range
Dim WorkRng1 As Range
On Error Resume Next
Set WorkRng1 = wsApple(Range("AA2"), Range("AB2").End(xlDown))
For Each Rng1 In WorkRng1
If Rng1.Value = 0 Then
Rng1.Value = ""
End If
Next Rng1

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'Remove zeros from blank linked cells
'Column A:D in tab Orange
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'

Dim Rng2 As Range
Dim WorkRng2 As Range
On Error Resume Next
Set WorkRng2 = wsOrange.Range(Range("A2"), Range("D2").End(xlDown))
For Each Rng2 In WorkRng2
If Rng2.Value = 0 Then
Rng2.Value = ""
End If
Next Rng2

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'Remove zeros from blank linked cells
'Column AD in tab Grape
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'

Dim Rng3 As Range
Dim WorkRng3 As Range
On Error Resume Next
Set WorkRng3 = wsGrape(Range("AD2"), Range("AD2").End(xlDown))
For Each Rng3 In WorkRng3
If Rng3.Value = 0 Then
Rng3.Value = ""
End If
Next Rng3


'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'Remove zeros from blank linked cells
'Column G in tab Pear
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'

Dim Rng4 As Range
Dim WorkRng4 As Range
On Error Resume Next
Set WorkRng4 = wsPear.Range(Range("G2"), Range("G2").End(xlDown))
For Each Rng4 In WorkRng
If Rng4.Value = 0 Then
Rng4.Value = ""
End If
Next Rng4

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'Application settings'
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 1

在多个工作表中替换

Option Explicit
Sub ReturnZerosAsBlanks()
' Constants
Dim SheetNames As Variant
SheetNames = VBA.Array("Apple", "Orange", "Grape", "Pear")
Dim Cols As Variant
Cols = VBA.Array("AA:AB", "A:D", "AD", "G")
Dim wb As Workbook
Set wb = ThisWorkbook 'The workbook containing this code.

' Toggle application settings
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

' Remove zeros from blank linked cells.
Dim ws As Worksheet, rng As Range, cel As Range, LastRow As Long, j As Long

' Loop through worksheets with names supplied in Sheet Names Array.
For j = 0 To UBound(SheetNames)

' Define Current Worksheet.
Set ws = wb.Worksheets(SheetNames(j))
' Using always the first column, calculate Last Row.
LastRow = ws.Cells(ws.Rows.Count, ws.Columns(Cols(j)).Column) _
.End(xlUp).Row
If LastRow < 2 Then GoTo NextSheet
' Define Criteria Range.
Set rng = ws.Columns(Cols(j)).Rows(2).Resize(LastRow - 1) ' 1 = 2 - 1

' This is faster, but doesn't work for formulas, although you should
' not do this when there are formulas in cells.
rng.Replace What:=0, _
Replacement:=Empty, _
LookAt:=xlWhole
' This will work for formulas, too.
'        For Each cel In rng.Cells
'            If cel.Value = 0 Then
'                cel.Value = Empty
'            End If
'        Next cel
NextSheet:
Next j

' Toggle application settings.
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' Inform user.
MsgBox "Done."
End Sub