Code umbauen

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("mailadresse").GetRootFolder.Folders.Item("Test")
'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 = arrLines(3)
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