Emails in Excel auslesen

Sub ReadOutlookMails()
Dim olApp      As Object   ' das Outlook-Objekt
Dim objFolder  As Object   ' der Standard-Posteingangsordner
Dim objItem    As Object   ' ein Objekt in objFolder
Dim i          As Long     ' Zeilennummer
Dim objRe      As Object   ' ein Regular-Expression Objekt
Dim objMc      As Object   ' eine MatchCollection, das Ergebnis von objRe.Execute
Dim objMatch   As Object   ' ein Match, d.h. ein Eintrag der Form "irgendwas:sonstwas"
Dim objDic     As Object   ' ein Dictionary-Objekt, Key sind die möglichen Werte vor dem  _
Doppelpunkt, Item ist die Spaltenummer wo das hinsoll
Dim varKey     As Variant  ' ein Key im Dictionary
Dim strKey     As String   ' dito
Set objDic = CreateObject("scripting.dictionary")
i = 3 'abhängig von den Variablen (Betreff, Absender, ...)
'erst Zeile, dann Spalte
Cells(1, 1).Value = "Betreff" 'schreibt die Überschriften in Zeile 1
Cells(1, 2).Value = "Absender"
Cells(1, 3).Value = "Datum"
For Each varKey In Array("Projekt", "Tätigkeit", "Stunden") 'gleicher Aufbau mehr Variablen  _
möglich
i = i + 1
objDic(varKey) = i
Cells(1, i).Value = varKey
Next
Set objRe = CreateObject("vbscript.regexp")
objRe.Global = True
objRe.MultiLine = True
objRe.Pattern = "^(.*?):[ \t]*(.*?)[\r\n]?$"
Set olApp = CreateObject("outlook.application")
Set objFolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6) ' 6 = olFolderInbox
i = 1
For Each objItem In objFolder.Items
If TypeName(objItem) = "MailItem" Then
Set objMc = objRe.Execute(objItem.Body)
If objMc.Count > 0 Then
Cells(i + 1, 1).Value = objItem.Subject 'nimmt Betreff in Spalte A
Cells(i + 1, 2).Value = objItem.Sender 'nimmt Absender in Spalte B
Cells(i + 1, 3).Value = objItem.ReceivedTime 'Datum in Spalte C
i = i + 1
For Each objMatch In objMc
strKey = objMatch.Submatches(0)
If objDic.Exists(strKey) Then Cells(i, objDic(strKey)) = objMatch.Submatches(1)
Next
End If
End If
Next
objDic.RemoveAll
Set objDic = Nothing
Set objMc = Nothing
Set objRe = Nothing
Set objFolder = Nothing
Set olApp = Nothing
End Sub