Hallo, 

Ich bekomme täglich mehrere Emails  von Paypal in welcher sich die Lieferadressen befinden. Ich möchte gerne mit einem Makro, am besten von Excel aus aber wenn es nur in Outlook geht ist das auch ok, diese Leiferadresse in eine Excel Tabelle eintragen. Ich habe nun schon ein paar sehr Hilfreiche Tips gefunden aber komme nicht weiter. Ich möchte die Lieferadresse mit RegEx finden. 

So wird die Lieferadresse in der Email angezeigt:

Lieferadresse

Max Mustermann

Musterstraße 1

11111 Musterstadt

Deutschland

Mein Aktueller Code funktioniert ganz gut  wenn ich Wörter in einer Zeile suchen möchte aber sobald es wie im Beispiel mit Zeilenumbrüchen getrennt ist findet er gar nichts mehr.

Option Explicit
 Private Const xlUp As Long = -4162

Sub CopyAllMessagesToExcel()
 Dim objOL As Outlook.Application
 Dim objItems As Outlook.Items
 Dim objFolder As Outlook.MAPIFolder
 Dim olItem As Outlook.MailItem
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim vText, vText2, vText3, vText4, vText5 As Variant
 Dim sText As String
 Dim rCount As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath As String
 Dim Reg1 As Object
 Dim M1 As Object
 Dim M As Object
              
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
 strPath = enviro & "\Desktop\neu.xlsx"
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0
     'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Tabelle1")

    'Find the next empty line of the worksheet
     rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
     rCount = rCount + 1
     
    Set objOL = Outlook.Application
    Set objFolder = objOL.ActiveExplorer.CurrentFolder
    Set objItems = objFolder.Items
 
    For Each olItem In objItems
 
      On Error Resume Next

     With olItem
     
     sText = olItem.Body

     Set Reg1 = CreateObject("VBScript.RegExp")
    ' \s* = invisible spaces
    ' \d* = match digits
    ' \w* = match alphanumeric
     
    With Reg1
        .MultiLine = True
        .Pattern = "(\bLieferadresse\n (\w+).*)"
    End With
    If Reg1.Test(sText) Then
     
' each "(\w*)" and the "(\d)" are assigned a vText variable
        Set M1 = Reg1.Execute(sText)
        For Each M In M1
           vText = Trim(M.SubMatches(1))
           vText2 = Trim(M.SubMatches(2))
        Next
  
  xlSheet.Range("B" & rCount) = vText
  xlSheet.Range("c" & rCount) = vText2
  xlSheet.Range("d" & rCount) = .Subject
  xlSheet.Range("e" & rCount) = .ReceivedTime
  'xlSheet.Range("f" & rCount) = vText5

' next line
 rCount = rCount + 1

    End If
      ' do whatever
       Debug.Print .Subject
     
     End With
    Next
     xlWB.Close 1
     If bXStarted Then
         xlApp.Quit
     End If
     Set M = Nothing
     Set M1 = Nothing
     Set Reg1 = Nothing
     Set xlApp = Nothing
     Set xlWB = Nothing
     Set xlSheet = Nothing
     
    Set objItems = Nothing
    Set objFolder = Nothing
    Set objOL = Nothing

 End Sub

Wäre nett wenn mir jemand etwas auf die Sprünge helfen könnte mit dem .pattern ausdruck. 

Um das Ganze etwas abzurunden wäre es nicht schlecht wenn das Makro in Excel ausgeführt wird und nicht in Outlook, sodass alle ungelesenen Mails in einem bestimmten Ordner nach diesem Schema ausgelesen werden. 

Schonmal Danke im Vorraus

Lukas