Макрос для удаления строк с нулевыми значениями,сортировкой по нужным листам

Sub PRIMER()
'
Application.ScreenUpdating = False 'отключение обновления экрана
Dim lRow As Long 'переменные
Dim iCntr As Long
Dim sh As Object
lRow = 12
  For Each sh In ThisWorkbook.Sheets 'попытка сделать цикл для листов
If sh.Name <> "Ñâîä" Then
    For iCntr = lRow To 1 Step -1 'удаление строк с нулевыми значениями
        If Cells(iCntr, 2).Value = "0" And Cells(iCntr, 3).Value = "0" Then
            Rows(iCntr).Delete
        End If
    Next
    Range("B2:C12").Select 'замена формул значениями
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Range("A2:D12").Select 'сортировка
    Range("D2").Activate
    ActiveWorkbook.ActiveWorksheets.Sort.SortFields.Clear
    ActiveWorkbook.ActiveWorksheets.Sort.SortFields.Add Key:=Range( _
        "D2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.ActiveWorksheets.Sort
        .SetRange Range("A2:D12")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    End If
    Next
Application.ScreenUpdating = True
End Sub

Private Sub Test()
    Dim a, ws As Worksheet, r As Range, rw&
    a = Array("Пример1", "Пример2", "Пример3")
    
    For Each ws In ActiveWorkbook.Worksheets(a)
        Set r = ws.Range("B2:C12")
        r = r.Value
        For rw = r.Rows.Count To 1 Step -1
            If Application.CountIf(r.Rows(rw), 0) = 2 Then r(rw).EntireRow.Delete
        Next
        ws.Range("A2:D12").Sort ws.Range("D2"), xlDescending, Header:=xlGuess
    Next
End Sub