Probleme bei Makro in Outlook zum kopieren von Daten aus Mail in Excel

Sub Extract_EMails_Fiasco()
    'Pfad zur Excel-Datei  
    Const EXCELFILE = "D:\Daten.xlsx"  
    'Variablen  
    Dim fMails As Folder, ferledigt as Folder, mail As MailItem, txtContent As String, objExcel As Object, wb As Object, rngCurrent As Object, regex As Object, _
    ws As Object, items As items, col As New Collection

    'Ordner in Outlook referenzieren in dem die Mails liegen  
    Set fMails = Application.Session.Stores("Persönlicher Ordner").GetRootFolder.Folders("Posteingang")  
    'Ordner in dem die verarbeiteten Mails verschoben werden, hier ein Unterorder des Posteingangs mit dem Namen 'Ablage'  
    Set ferledigt = fMails.Folders("Ablage")  
    
    'Mails auf einen Satz mit bestimmtem Subject begrenzen  
    Set items = fMails.items.Restrict("@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001E"" like 'Data-2000-%'")  
    
    If items.count > 0 Then
        'collection nach Datum sortieren  
        items.Sort "[ReceivedTime]"  
        
        'Regex Objekt für die Suche nach E-Mail-Adressen  
        Set regex = CreateObject("vbscript.regexp")  
        regex.Global = False: regex.IgnoreCase = True: regex.MultiLine = False
        
        'Regex-Such-Pattern für die Mails  
        regex.pattern = "-(\d+)\s+\[([\d\.]+)\]:\s*([^\r\n]*)"  
        
        'Excel Objekt erzeugen  
        Set objExcel = CreateObject("Excel.Application")  
        objExcel.DisplayAlerts = False

        Set fso = CreateObject("Scripting.FileSystemObject")  
        If fso.FileExists(EXCELFILE) Then
            'Excel-Workbook öffnen  
            Set wb = objExcel.Workbooks.Open(EXCELFILE)
            Set ws = wb.sheets(1)
        Else
           'Wenn Excel-Datei nicht existiert erzeuge neue Excel-Datei  
            Set wb = objExcel.Workbooks.add
            'Überschriften erzeugen  
            Set ws = wb.sheets(1)
            With ws.Range("A1:C1")  
                .Value = Array("Nummer", "IP", "Status")  
                .Font.Bold = True
            End With
            'Spalten auf Textformat schalten  
            ws.Range("A:C").NumberFormat = "@"  
        End If
        Set rngCurrent = ws.Cells(ws.Rows.count, "A").End(-4162).Offset(1, 0)  
        
        For Each mail In items
            'Regex-Suche ausführen  
            Set matches = regex.Execute(mail.Body)
            ' Bei einem Treffer  
            If matches.count > 0 Then
                'die extrahierten Teile ins das Excel-Sheet übertragen  
                rngCurrent.Resize(1, 3).Value = Array(matches(0).submatches(0), matches(0).submatches(1), matches(0).submatches(2))
                ' Für den nächsten Datensatz den Zeiger eine Zeile weiter nach unten verschieben  
                Set rngCurrent = rngCurrent.Offset(1, 0)
            End If
            'die Mail einer Collection hinzufügen  
            col.add mail
        Next
        'Alle Mails die verarbeitet wurden in den Zielordner verschieben  
        For Each mail In col
            mail.Move ferledigt
        Next
        
        'Breiten der Spalten anpassen  
        ws.Range("A:C").EntireColumn.AutoFit  
        'Workbook speichern  
        wb.SaveAs EXCELFILE
        'Info anzeigen  
        MsgBox "Verarbeitung abgeschlossen! Excel wird nun angezeigt.", vbInformation  
        'Excel anzeigen  
        objExcel.DisplayAlerts = True
        objExcel.Visible = True
        
        'Objekte freigeben  
        Set objExcel = Nothing
        Set wb = Nothing
        Set ws = Nothing
        Set matches = Nothing
        Set mail = Nothing
        Set regex = Nothing
        Set fso = Nothing
    Else
        MsgBox "Keine Mails zum Bearbeiten im Ordner", vbExclamation  
    End If
End Sub