VBA Zellen markieren bis Inhalt sich ändert

Sub FilterAndSave()
    'Exportpfad für die PDF Dateien  
    Const EXPORT_PATH = "D:\export"  
    'Variablen  
    Dim keys, strNumber As String, cell As Range, fso As Object, dic As Object, i as integer
    'Objects  
    Set dic = CreateObject("Scripting.Dictionary")  
    Set fso = CreateObject("Scripting.FileSystemObject")  
    
    'Ausgabeordner erstellen falls nicht vorhanden  
    If Not fso.FolderExists(EXPORT_PATH) Then MkDir EXPORT_PATH
    
    Application.ScreenUpdating = False
    With ActiveSheet
        'AutoFilter deaktivieren  
        .AutoFilterMode = False
        'einmalige Nummern im Dictionary speichern  
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)  
            If cell.Value <> "" And Not dic.Exists(cell.Value) Then  
                dic.Add cell.Value, ""  
            End If
        Next
        
        keys = dic.keys
        'Für alle Nummern im Dictionary  
        For i = 0 To dic.Count - 1
            strNumber = keys(i)
            'Filtere das Sheet nach der Nummer  
            .UsedRange.AutoFilter 1, strNumber
            'Speichere das Sheet als PDF  
            .ExportAsFixedFormat xlTypePDF, EXPORT_PATH & "\" & strNumber & ".pdf"  
        Next
        'AutoFilter deaktivieren  
        .AutoFilterMode = False
        
        'Exportierte Zeilen löschen  
        .Range("A2:E" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents  
    End With
    
    Application.ScreenUpdating = True
    MsgBox "Fertig", vbInformation  
    Set fso = Nothing
    Set dic = Nothing
End Sub