VB-Makro für Outlook gesucht - Suche Mails nach "Angezeigtem Namen" und Lösche alle bis auf die neuesten Anzahl n

Sub keepNewestXMailsFromIndividualSenders()
    Dim folderMails As Folder, mail As MailItem, dic As Object, intKeep As Integer, itms As items, x As Integer, i As Integer, keys As Variant
    'Anzahl Mails die pro Sendername erhalten bleiben sollen  
    intKeep = 5
    'Dictionary  
    Set dic = CreateObject("Scripting.Dictionary")  
    'Ordner aus dem die Mails verarbeitet werden  
    Set folderMails = Application.Session.Stores("KundenSicherungen").GetRootFolder.Folders("_Alle")  
    
    'lade alle individuellen Sendernamen in ein Dictionary  
    For Each mail In folderMails.items
        If Not dic.Exists(mail.SenderName) Then
            dic.add mail.SenderName, ""  
        End If
    Next
    
    'Iteriere über das Dictionary  
    keys = dic.keys
    For i = 0 To dic.count - 1
        'Mails nach Sendername filtern  
        Set itms = folderMails.items.Restrict("[Sendername] = '" & keys(i) & "'")  
        If Not itms Is Nothing Then
            ' wenn die Anzahl der zu behaltenen Mails den angegebenen Wert übersteigt  
            If itms.count > intKeep Then
                'Mails nach Datum absteigend sortieren  
                itms.Sort "[ReceivedTime]", True  
                'Überzählige Mails des Sendernamens löschen  
                For x = itms.count To intKeep + 1 Step -1
                    itms.Item(x).Delete
                Next
            End If
        End If
    Next
    Set dic = Nothing
End Sub