Блог

Когда я запускаю код, обновляется только один лист, например, 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
  

Заменить на нескольких рабочих листах

 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