Для L oop Оптимизация скорости VBA

Question

У меня есть этот небольшой код, который в основном делает oop через таблицу, go имя по имени, фильтрует данные по этому c имени и подсчитывает, сколько раз человек достиг цели. Но имен мало (104) и на это уходит много времени. Я хотел бы знать, есть ли способ ускорить этот процесс.

Вот код:

lastrow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

 
For i = 2 To Worksheets("Sheet1").UsedRange.Columns.Count Step 2
On Error Resume Next
 Worksheets("Data").ShowAllData
 
 Worksheets("Sheet1").Activate
    For x = 4 To lastrow
    Worksheets("Data").ShowAllData
       name = Worksheets("Sheet1").Cells(x, 1)
       month = Worksheets("Sheet1").Cells(3, i)
        Worksheets("Data").Activate
        Range("AD1").AutoFilter Field:=30, Criteria1:=month
       Range("B1").AutoFilter Field:=2, Criteria1:=name
       
        countrows = Worksheets("Data").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
       If (countrows <= 1) Then GoTo Nextx
       
       
       datalast = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Offset(2).Row
      
       Set rn = Range("Z2")
       Set rn = Range(rn, rn.End(xlDown)).SpecialCells(xlCellTypeVisible)
       For Each cell In rn
           If cell.Value > 0.9 Then ppercount = ppercount + 1
            Next cell
       
            
       
       Worksheets("Data").ShowAllData
       Worksheets("Sheet1").Cells(x, i).Value = ppercount
       Worksheets("Sheet1").Activate
       ppercount = 0
Nextx:
    Next x
    
Nexti:
    Next i



Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True