EMail auslesen, verschieben und mit Excel ausgelesene Daten weiterverarbeiten

Sub ExtractPrinterAlerts()
    Dim fMails As Folder, mail As MailItem, txtContent As String, arrLines As Variant, objExcel As Object, wb As Object, sheet As Object, rngStart As Object, rngCurrent As Object, fErledigt as Object, txtStatus as String, txtTime as String, txtMessage as String, txtMachine as String, txtSN as String, txtIP as String, txtLocation as String, txtCountTotal as String, txtCountColor as String
    
    'Pfad zur Excel-Datei  
    Const EXCELFILE = "c:\PrinterAlerts.xlsx"  
    
    'Ordner in Outlook referenzieren  
    Set fMails = Application.Session.Stores("user@domain.net").GetRootFolder.Folders("Druckeralerts")  
    'Unterordner referenzieren in den die Mails verschoben werden wenn sie bearbeitet wurden  
    Set fErledigt = fMails.Folders("erledigt")  
    
    
    If fMails.Items.Count > 0 Then
        'Excel Objekt erzeugen  
        Set objExcel = CreateObject("Excel.Application")  
        objExcel.DisplayAlerts = False
        
        'Excelfile öffnen  
        Set wb = objExcel.Workbooks.Open(EXCELFILE)
        
        'Daten kommen in erstes Worksheet  
        Set sheet = wb.Worksheets(1)
        
        'Startzelle in Spalte A ermitteln  
        Set rngStart = sheet.Cells(sheet.Rows.Count,1).End(-4162).Offset(1, 0)
        Set rngCurrent = rngStart
        
        While fMails.Items.Count > 0
            
            'aktuelle Mail  
            Set mail = fMails.Items(1)
            
            'Body extrahieren  
            txtContent = mail.Body
            
            ' Zeilen in ein Array schreiben  
            arrLines = Split(txtContent, vbNewLine, -1, vbTextCompare)
            
            ' Zeilen den Variablen zuweisen  
            txtStatus = arrLines(1)
            txtMessage = arrLines(2)
            txtTime = Trim(Split(arrLines(3), ":", 2, vbTextCompare)(1))  
            txtMachine = arrLines(4)
            txtSN = arrLines(5)
            txtLocation = arrLines(6)
            txtIP = arrLines(7)
            txtCountTotal = Trim(Split(arrLines(8), ":", 2, vbTextCompare)(1))  
            txtCountColor = Trim(Split(arrLines(9), ":", 2, vbTextCompare)(1))  
            
            'Setze Werte im Sheet  
            With rngCurrent
                .Value = txtStatus
                .Offset(0, 1).Value = txtMessage
                .Offset(0, 2).Value = txtTime
                .Offset(0, 3).Value = txtMachine
                .Offset(0, 4).Value = txtSN
                .Offset(0, 5).Value = txtLocation
                .Offset(0, 6).Value = txtIP
                .Offset(0, 7).Value = txtCountTotal
                .Offset(0, 8).Value = txtCountColor
            End With
            'Excel Zeile eins nach unten verschieben  
            Set rngCurrent = rngCurrent.Offset(1, 0)
            
            ' Mail in den 'Erledigt' Ordner verschieben  
            mail.Move fErledigt
        Wend
        'Workbook speichern  
        wb.Save
        'Excel anzeigen  
        objExcel.Visible = True
        objExcel.DisplayAlerts = True
    Else
        MsgBox "Keine Mails zum Bearbeiten im Ordner", vbExclamation  
    End If
    
    Set objExcel = Nothing
    Set wb = Nothing
    Set sheet = Nothing
    Set mail = Nothing
End Sub

Sub ExtractMailInfo()
    Dim fMails As Object, mail As Object, txtContent As String, arrLines As Variant, objExcel As Object, wb As Object, sheet As Object, rngStart As Object, rngCurrent As Object, objOL As Object, fErledigt as Object, txtStatus as String, txtTime as String, txtMessage as String, txtMachine as String, txtSN as String, txtIP as String, txtLocation as String, txtCountTotal as String, txtCountColor as String

    ' Outlook Object erzeugen  
    Set objOL = CreateObject("Outlook.Application")  
    
    'Ordner in Outlook referenzieren  
    Set fMails = objOL.Session.Stores.Item("user@domain.net").GetRootFolder.Folders.Item("Druckeralerts")  
    'Unterordner referenzieren in den die Mails verschoben werden wenn sie bearbeitet wurden  
    Set fErledigt = fMails.Folders("erledigt")  
    
    
    If fMails.Items.Count > 0 Then

        'Workbook setzen  
        Set wb = ActiveWorkbook
        
        'Daten kommen in erstes Worksheet  
        Set sheet = wb.Worksheets(1)
        
        'Startzelle in Spalte A ermitteln  
        Set rngStart = sheet.Cells(Rows.Count,1).End(xlUp).Offset(1, 0)
        Set rngCurrent = rngStart
        
        While fMails.Items.Count > 0
            
            'aktuelle Mail  
            Set mail = fMails.Items(1)
            
            'Body extrahieren  
            txtContent = mail.Body
            
            ' Zeilen in ein Array schreiben  
            arrLines = Split(txtContent, vbNewLine, -1, vbTextCompare)
            
            ' Zeilen den Variablen zuweisen  
            txtStatus = arrLines(1)
            txtMessage = arrLines(2)
            txtTime = Trim(Split(arrLines(3), ":", 2, vbTextCompare)(1))  
            txtMachine = arrLines(4)
            txtSN = arrLines(5)
            txtLocation = arrLines(6)
            txtIP = arrLines(7)
            txtCountTotal = Trim(Split(arrLines(8), ":", 2, vbTextCompare)(1))  
            txtCountColor = Trim(Split(arrLines(9), ":", 2, vbTextCompare)(1))  
            
            'Setze Werte im Sheet  
            rngCurrent.Value = txtStatus
            rngCurrent.Offset(0, 1).Value = txtMessage
            rngCurrent.Offset(0, 2).Value = txtTime
            rngCurrent.Offset(0, 3).Value = txtMachine
            rngCurrent.Offset(0, 4).Value = txtSN
            rngCurrent.Offset(0, 5).Value = txtLocation
            rngCurrent.Offset(0, 6).Value = txtIP
            rngCurrent.Offset(0, 7).Value = txtCountTotal
            rngCurrent.Offset(0, 8).Value = txtCountColor
            
            'Excel Zeile eins nach unten verschieben  
            Set rngCurrent = rngCurrent.Offset(1, 0)
            
            ' Mail in den 'Erledigt' Ordner verschieben  
            mail.Move fErledigt
        Wend
        'Workbook speichern  
        wb.Save
    Else
        MsgBox "Keine Mails zum Bearbeiten im Ordner", vbExclamation  
    End If
    
    Set objOL = Nothing
    Set wb = Nothing
    Set sheet = Nothing
    Set mail = Nothing
End Sub

Set fMails = objOL.Session.Stores.Item("user@domain.net").GetRootFolder.Folders.Item("Druckeralerts") 

Set fMails = objOL.Session.Stores.Item("user@domain.net").GetRootFolder.Folders.Item("Posteingang") .Folders.Item("Test")

UBound(arrLines)

for i = 0 to UBound(arrLines)
  ' Zeile verarbeiten, als Beispiel nur ausgeben  
  Msgbox arrLines(i)
  '.....  
Next

Set rngCurrent = rngCurrent.Offset(1, 0) 

rngCurrent.Offset(0,1).Value = "Wert für Spalte B"  
rngCurrent.Offset(0,2).Value = "Wert für Spalte C"  
rngCurrent.Offset(0,3).Value = "Wert für Spalte D"  
' usw...  

Sub ExtractMailInfo()
    Dim fMails As Object, mail As Object, txtContent As String, arrLines As Variant, objExcel As Object, wb As Object, sheet As Object, rngStart As Object, rngCurrent As Object, objOL As Object, fErledigt As Object, colMove As New Collection, strSubject As String, mailItems As Object

    ' Outlook Object erzeugen  
    Set objOL = CreateObject("Outlook.Application")  
    
    'Ordner in Outlook referenzieren  
    Set fMails = objOL.Session.Stores.Item("user@domain.det").GetRootFolder.Folders.Item("Druckeralerts")  
    'Unterordner referenzieren in den die Mails verschoben werden wenn sie bearbeitet wurden  
    Set fErledigt = fMails.Folders("erledigt")  
    
    'Subject nach dem gefiltert wird  
    strSubject = "Dein Subject das du suchst"  
    
    If fMails.Items.Count > 0 Then

        'Workbook setzen  
        Set wb = ActiveWorkbook
        
        'Daten kommen in erstes Worksheet  
        Set sheet = wb.Worksheets(1)
        
        'Startzelle in Spalte A ermitteln  
        Set rngStart = sheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Set rngCurrent = rngStart
        
        'Mails nach Subject filtern  
        Set mailItems = fMails.Items.Restrict("@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001f"" like '%" & strSubject & "%'")  
        
        If Not mailItems Is Nothing Then
            For Each mail In mailItems
                
                'Body extrahieren  
                txtContent = mail.Body
                
                'Zeilen in ein Array schreiben  
                arrLines = Split(txtContent, vbNewLine, -1, vbTextCompare)
                
                'Zeilen den Variablen zuweisen  
                txtStatus = arrLines(1)
                txtMessage = arrLines(2)
                txtTime = Trim(Split(arrLines(3), ":", 2, vbTextCompare)(1))  
                txtMachine = arrLines(4)
                txtSN = arrLines(5)
                txtLocation = arrLines(6)
                txtIP = arrLines(7)
                txtCountTotal = Trim(Split(arrLines(8), ":", 2, vbTextCompare)(1))  
                txtCountColor = Trim(Split(arrLines(9), ":", 2, vbTextCompare)(1))  
                
                'Setze Werte im Sheet  
                rngCurrent.Value = txtStatus
                rngCurrent.Offset(0, 1).Value = txtMessage
                rngCurrent.Offset(0, 2).Value = txtTime
                rngCurrent.Offset(0, 3).Value = txtMachine
                rngCurrent.Offset(0, 4).Value = txtSN
                rngCurrent.Offset(0, 5).Value = txtLocation
                rngCurrent.Offset(0, 6).Value = txtIP
                rngCurrent.Offset(0, 7).Value = txtCountTotal
                rngCurrent.Offset(0, 8).Value = txtCountColor
                
                'Excel Zeile eins nach unten verschieben  
                Set rngCurrent = rngCurrent.Offset(1, 0)
                
                ' Mail zur Collection hinzufügen  
                colMove.Add mail
            Next
            'Mails verschieben  
            For Each m In colMove
                m.Move fErledigt
            Next
        End If
        'Workbook speichern  
        'wb.Save  
    Else
        MsgBox "Keine Mails zum Bearbeiten im Ordner", vbExclamation  
    End If
    
    Set objOL = Nothing
    Set wb = Nothing
    Set sheet = Nothing
    Set mail = Nothing
    Set mailItems = Nothing
    set colMail = Nothing
End Sub

mailItems.Sort "[ReceivedTime]",False

Set regex = CreateObject("vbscript.regexp")  
regex.Global = False: regex.IgnoreCase = True: regex.MultiLine = False
regex.Pattern = "Fahrgestellnummer ([^\s]*) begann an ([^.]*)[\s\S]*?Batterie-Ladestatus beträgt (\d+)[\s\S]*? Fahrleistung von (\d+)"  
set matches = regex.Execute(txtContent)
if matches.count > 0 then
   strFarhgestellnummer = matches(0).submatches(0)
   strDatum = matches(0).submatches(1)
   strBatterieLadestatus = matches(0).submatches(2)
   strFahrleistung = matches(0).submatches(3)
End if