Cells(s, 1).EntireRow.Delete start working too slowly with new MS 365. Some fastes option?

[beaster]

Dim r, k As Integer
    Dim kdnr As String
    Dim kdname As String
    Dim Arr As Variant
    
    Application.PrintCommunication = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
            
    r = 3
    
    Arr = Array(".", ",", ";", "\", "/", "?", "'", ":", "<", ">", "*", "%", "&", "@", "#", "$")
    
    Do Until IsEmpty(Cells(r, 1))
    
    Sheets(2).Select
    
    If Cells(r, 11) < 1 Then
    
    r = r + 1
    
    Else

    kdnr = Cells(r, 2)
    kdname = Cells(r, 3)
        
    For i = LBound(Arr) To UBound(Arr)
        kdname = Replace(kdname, Arr(i), "")
    Next i
    
    Sheets(1).Copy
    
    ActiveWorkbook.SaveAs Filename:="H:\Branches\DACH330\Sales\POHLADAVKY\KlientiMakro\" & kdname & ".xlsx"
    
    Dim s As Integer
    Dim rng As Range
    
    s = 2
    Do Until IsEmpty(Cells(s, 1))
    If Cells(s, 2) <> kdnr Then
    Cells(s, 1).EntireRow.Delete
    Else
    s = s + 1
    End If
    Loop
    
    ActiveWindow.Close savechanges:=True
    
    Windows(wbName).Activate
    Sheets(2).Select
    
    r = r + 1
    
    End If
      
    Loop
    
    Application.PrintCommunication = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True