Не работает цикл For. Next - VBA

Формулировка задачи:

Добрый день, в VBA не силен, помогите пожалуйста понять почему не работает цикл. Задача при нажатии на кнопку создать несколько новых отчетов, если в таблице отмечено несколько полей, но на практике при активации кнопки создается только один лист, а все остальные не работают. Пример файла во вложении Сам код макроса ниже

Sub Macro1()
Dim счетчик As Integer, sData As String, sNom As String, sFIO As String, sMT As String, sGOSNomt As String, sPric As String, sMesto As String, sVidRab As String, sNach As Date, sKon As Date, NewSheet
For счетчик = 3 To 33 Step 1
If Cells(счетчик, 1) = "x" Then
        Data = Cells(счетчик, 2)
        sNom = Cells(счетчик, 3)
        sFIO = Cells(счетчик, 4)
        sMT = Cells(счетчик, 5)
        sGOSNomt = Cells(счетчик, 6)
        sPric = Cells(счетчик, 7)
        sMesto = Cells(счетчик, 8)
        sVidRab = Cells(счетчик, 9)
        sNach = Cells(счетчик, 10)
        sKon = Cells(счетчик, 11)
    On Error Resume Next
        Set NewSheet = Sheets(sFIO)
        If NewSheet Is Nothing Then
            Sheets("412-АПК").Copy Before:=Sheets(Sheets.Count)
            Sheets("412-АПК (2)").Name = sNom
            Cells(8, 3) = sData
            Cells(3, 8) = sNom
            Cells(5, 7) = sFIO
            Cells(6, 12) = sMT
            Cells(7, 12) = sGOSNomt
            Cells(8, 12) = sPric
            Cells(12, 3) = sMesto
            Cells(12, 4) = sVidRab
            Cells(25, 11) = sNach
            Cells(27, 11) = sKon
        Else
            MsgBox "Лист с таким именем уже существует!", 48, "Ошибка!"
        End If
        End If
Next счетчик

End Sub

Решение задачи: «Не работает цикл For. Next»

textual
                            Листинг программы 
                        

                            Sub Macro1()
Dim счетчик As Integer, sData As String, sNom As String, sFIO As String, sMT As String, sGOSNomt As String, sPric As String, sMesto As String, sVidRab As String, sNach As Date, sKon As Date, NewSheet
Dim sh As Worksheet
 
Set sh = ActiveSheet
With sh
For счетчик = 3 To 33 Step 1
If .Cells(счетчик, 1) = "x" Then
        Data = .Cells(счетчик, 2)
        sNom = .Cells(счетчик, 3)
        sFIO = .Cells(счетчик, 4)
        sMT = .Cells(счетчик, 5)
        sGOSNomt = .Cells(счетчик, 6)
        sPric = .Cells(счетчик, 7)
        sMesto = .Cells(счетчик, 8)
        sVidRab = .Cells(счетчик, 9)
        sNach = .Cells(счетчик, 10)
        sKon = .Cells(счетчик, 11)
    On Error Resume Next
        Set NewSheet = Sheets(sFIO)
        If NewSheet Is Nothing Then
            Sheets("412-АПК").Copy Before:=Sheets(Sheets.Count)
            Sheets("412-АПК (2)").Name = sNom
            Cells(8, 3) = sData
            Cells(3, 8) = sNom
            Cells(5, 7) = sFIO
            Cells(6, 12) = sMT
            Cells(7, 12) = sGOSNomt
            Cells(8, 12) = sPric
            Cells(12, 3) = sMesto
            Cells(12, 4) = sVidRab
            Cells(25, 11) = sNach
            Cells(27, 11) = sKon
        Else
            MsgBox "Лист с таким именем уже существует!", 48, "Ошибка!"
        End If
        End If
Next счетчик
End With
        
End Sub
                        