# Excel VBA - Emailbody aus Outlook auslesen



## jerry0110 (5. Februar 2020)

Hallo zusammen,

ich möchte gerne von täglichen Emails den Body auslesen.
In dem Body Text ist eine Tabelle die mir Daten liefert.

Diese sieht wie folgt aus:


SenderMassageSPAM MailsOther MsgAdult Spam MailsVirus Mailstest@xyz.de20010253040info@xyz.de50010205214

Und dann geht das immer so weiter. 

Ich möchte diese Tabelle auslesen und dann in eine Tabelle einfügen mit Datum, von wann die Email ist. 
So dass ich diese dann auswerten kann. 

Kann mir jemand da unter die Arme greifen? Habe leider nichts passendes im Internet gefunden.


----------



## Yaslaw (5. Februar 2020)

Jetzt ist die grosse Frage, in was für einem Format die Tabelle vorliegt.
Kannst du mal ein Beispielmail speichern und zippen und dann hier hochladen?


----------



## jerry0110 (5. Februar 2020)

Hi,

anbei die Email


----------



## Yaslaw (5. Februar 2020)

Die Tabelle kommt im Body-Attribut als Text heraus. Die Zeilen sind mit jeweils 2 Wagenrücklauf+Zeilenumbruch getrennt.

Das kann man ausnutzen und ein RegEx setzen.
Hier mein Test: Regex101 - online regex editor and debugger

Und als Code:

```
Public Sub mailTest()
    Const C_MAPI = "myMailadresse@firma.com"
    Const C_FOLDER = "TEST"
    
    'Das Test-Mail auslesen
    Dim otl As Outlook.Application:     Set otl = New Outlook.Application
    Dim ns As Outlook.Namespace:        Set ns = otl.GetNamespace("MAPI")
    Dim fld As Outlook.MAPIFolder:      Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
    Dim mail As Outlook.MailItem:       Set mail = fld.items.GetFirst
    
    'RegExp definieren
    Dim rx As Object:                   Set rx = CreateObject("VBScript.RegExp")
    rx.pattern = "\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)"
    rx.ignoreCase = True
    rx.Global = True
    
    'Prüfen ob der Body eine Tabelle enthält
    If Not rx.test(mail.body) Then
        MsgBox "Mailbody passt nicht"
        Exit Sub
    End If
    
    'Mit dem RegEx die einzelnen Zeilen auslsen
    Dim match As Object: For Each match In rx.execute(mail.body)
        Dim items As Object: Set items = match.SubMatches
        '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
        Debug.Print items(0), items(1), items(2), items(3), items(4), items(5)
    Next match
End Sub
```

Ausgabe:

```
xyz@info.de   1557          0             1557          0             0
xyz@info.de   1344          0             1344          0             0
xyz@info.de   135           0             135           0             0
xyz@info.de   25            0             25            0             0
xyz@info.de   8             0             8             0             0
xyz@info.de   4             0             4             0             0
```


----------



## jerry0110 (5. Februar 2020)

Ich habe den Code jetzt in eine Excel eingebaut und dann oben meine Emailadresse und das Postfach angegeben wo die Mail drin ist. Wenn ich es starte dann kommt direkt in Zeile 6 die Fehlermeldung "Fehler beim Kompilieren:  Benutzerdefinierter Typ nicht definiert


----------



## Yaslaw (5. Februar 2020)

Ich dachte, die Mailgeschichte per se hast du drin. Egal. Setze eine Referenz auf
`Microsoft Outlook 16.0 Object Library`
Wobei die Zahl 16 bei dir auch eine andere sein kann.


----------



## jerry0110 (5. Februar 2020)

Yaslaw hat gesagt.:


> Die Tabelle kommt im Body-Attribut als Text heraus. Die Zeilen sind mit jeweils 2 Wagenrücklauf+Zeilenumbruch getrennt.
> 
> Das kann man ausnutzen und ein RegEx setzen.
> Hier mein Test: Regex101 - online regex editor and debugger
> ...



Ich habe jetzt bei Const C_MAPI meine Emailadresse von meinem Postfach reingeschrieben und bei dem Folder den neu angelegten Ordner Test. Leider sagt er immer das er den Ordner nicht findet.

Ich habe dann mal aus ns.Folders(C_MAPI).Folders(C_FOLDER)

ns.GetDefaultFolder(olFolderInbox).Folders("Test") gemacht. 
Dann kommt keine Fehlermeldung aber es kommt kein Debug Print. Es wird nichts ausgegeben.
Im Ordner Test ist die Email drin, die ich hier reingepackt habe.


----------



## Yaslaw (5. Februar 2020)

Ich kenne deine Ordnerstruktuir im Outlook nicht. Bei mir sieht sie so aus.
Unter dem Zensurbalken ist der Ordner, den ich im Code `C_MAPI` genannt habe
Darunter habe ich den TEST. Du musst dih halt bei dir entsprechen durch deine Struktur angeln.


----------



## jerry0110 (5. Februar 2020)

Das habe ich jetzt genauso bei mir. 

Habe jetzt nach der If Schleife eine Msgbox eingefügt. (MsgBox rx.test(mail.Body))
Die gibt mir "WAHR" aus. 

Also müsste er dann ja den Debug.Print ausführen. Macht er aber nicht.

Aber wenn ich eine Msgbox (msgbox items(0)) am Ende ausführe bekomme ich die Daten.
Dann muss ich ja nur noch statt msgbox die Werte in die Tabelle einführen.


----------



## Yaslaw (5. Februar 2020)

Der Debug.Print ist ja auch nur zu Testzwecken um das Resultat im Direktfenster auszugeben.


----------



## jerry0110 (6. Februar 2020)

Ich habe hierzu noch mal eine Frage.
Wenn ich das Array items(0) über die msgbox aufrufe funktioniert das ohne Probleme.

Wenn ich jetzt den u. s. Code nutze, dann kommt immer der Fehler, Objekt unterstützt diese Eigenschaft oder Methode nicht. Warum? Auch ohne .Value klappt es bei items nicht


```
If items(0) = "xyz@test.de" Then
            ThisWorkbook.Worksheet("xyz@test.de").Range("B2").Value = items(1).Value
            ThisWorkbook.Worksheet("xyz@test.de").Range("C2").Value = items(2).Value
            ThisWorkbook.Worksheet("xyz@test.de").Range("D2").Value = items(3).Value
            ThisWorkbook.Worksheet("xyz@test.de").Range("E2").Value = items(4).Value
            ThisWorkbook.Worksheet("xyz@test.de").Range("F2").Value = items(5).Value
        End If
```


----------



## Yaslaw (6. Februar 2020)

Warum itesm(#)*.Value*?
Und wo GENAU kommt WELCHER Fehle wenn du ohne  .Value arbeitest?
 Schon bei items(1) oder erst bei items(5)?

`ThisWorkbook.Worksheet("xyz@test.de").Range("B2").Value = items(1)`


Setz mal ein Breakpoint und schau die items. mal genauer an.


----------



## jerry0110 (6. Februar 2020)

Der Fehler kommt direkt beim "
ThisWorkbook.Worksheet("xyz@test.de").Range("B2").Value = items(1).Value
"
ich habe alle items mit msgbox(en) vorher versehen. 
Items(1)  = xyz@test.de
items(2) = eine Zahl
.
.
.

In der msgbox wird alles korrekt angezeigt.


----------



## jerry0110 (6. Februar 2020)

Wenn ich einen Breakpoint lege und mit der Maus über die einzelnen items gehe, dann sehe ich alle werte die es enthält.


----------



## Yaslaw (6. Februar 2020)

Finde den Unterschied, das Erste ist mein Code, der Zweite deiner.

`ThisWorkbook.Worksheet("xyz@test.de").Range("B2").Value = items(1)`
`ThisWorkbook.Worksheet("xyz@test.de").Range("B2").Value = items(1).Value`

Zudem:


> Warum itesm(#)*.Value*?


----------



## jerry0110 (6. Februar 2020)

Das .value hab ich schon lange raus genommen. 
Es steht jetzt = items(1) 

Aber auch da macht der den Fehler.


----------



## Yaslaw (6. Februar 2020)

Bei mir wird sogar markiert, was falsch ist. Es markiert `Worksheet`.




Ein Workbook hat kein Property names Worksheet. Jedoch hat es Worksheets 

`ThisWorkbook.Worksheets("xyz@test.de").Range("B2").Value = items(1)`


----------



## jerry0110 (6. Februar 2020)

Yaslaw hat gesagt.:


> Bei mir wird sogar markiert, was falsch ist. Es markiert `Worksheet`.
> 
> Anhang anzeigen 66268
> 
> ...



 sorry


----------



## jerry0110 (6. Februar 2020)

Einträge funktionieren jetzt und er schreibt es in die Spalte.

So jetzt kommt das nächste Problem.

Ich muss den Email Betreff und das Datum der Mail auslesen.
Anhand des Betreffs muss der untere Code dann in das richtige Sheet geschrieben werden.
Funktioniert aber leider nicht. 

Ich hatte zum Testen nach der For Each olMail 
	
	
	



```
msgbox olMail.subject
```
 stehen und er hat dann auch den Betreff ausgegeben. In der Schleife selber macht er das leider nicht. 

folgendes habe ich zum Guten gegeben:


```
For Each olMail In olFolder.Items
        
        If olMail.Subject = "*Auswertung Resa ausgehende Emails*" Then
            
           'Mit dem RegEx die einzelnen Zeilen auslsen
          
           letzte = Sheets("Gesamt Eingang").UsedRange.SpecialCells(xlCellTypeLastCell).Row
                
           For Each match In rx.Execute(mail.Body)
           Set Items = match.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
          
               ziel.Range("A" & letzte).Value = Format(olMail.ReceivedTime, "DD.MM.YYYY") - 1
               ziel.Range("B" & letzte).Value = Items(0)
               ziel.Range("C" & letzte).Value = Items(1)
               ziel.Range("D" & letzte).Value = Items(2)
               ziel.Range("E" & letzte).Value = Items(3)
               ziel.Range("F" & letzte).Value = Items(4)
               ziel.Range("G" & letzte).Value = Items(5)
              
               letzte = letzte + 1
        
           Next match
        
        ElseIf olMail.Subject = "*Auswertung Resa eingehende Emails*" Then
            
        'Mit dem RegEx die einzelnen Zeilen auslsen
        
           letzte2 = Sheets("Gesamt Ausgang").UsedRange.SpecialCells(xlCellTypeLastCell).Row
                
           For Each match In rx.Execute(mail.Body)
           Set Items = match.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
          
               ziel2.Range("A" & letzte).Value = Format(olMail.ReceivedTime, "DD.MM.YYYY") - 1
               ziel2.Range("B" & letzte).Value = Items(0)
               ziel2.Range("C" & letzte).Value = Items(1)
               ziel2.Range("D" & letzte).Value = Items(2)
               ziel2.Range("E" & letzte).Value = Items(3)
               ziel2.Range("F" & letzte).Value = Items(4)
               ziel2.Range("G" & letzte).Value = Items(5)
              
               letzte2 = letzte2 + 1
        
           Next match
        
        End If
    
        
    Next
```


----------



## Yaslaw (6. Februar 2020)

Das solltest du doch wissen. = bedeutet *gleich* und nicht *enthält*. Die * im Vergleichstring würden also nur dann richtig sein, wenn auch das Subjekt * enthält

Was du haben willst ist `like`

```
?"abc" = "abc*"
False
?"abcde" = "abc*"
False

?"abc" like "abc*"
True
?"abcde" like "abc*"
True
```


----------



## jerry0110 (7. Februar 2020)

Das ist jetzt mein vollständiger Code. Jetzt habe ich natürlich im Netz geguckt, wie ich den Betreff und das Datum der Mail auslesen kann. Das klappt auch. ABER. Er nimmt jetzt nur die Mails in meinem Hauptpostfach und nicht mehr aus dem Test Ordner.


```
For Each olMail In olFolder.Items        

        If olMail.Subject Like "*Auswertung Resa ausgehende Emails" Then
```

Das ist der Teil, wo ich auf die Teile der Email zugreife. In dem Code unten wird ja auch auf die Email zugegriffen. Wie kann ich jetzt das so nutzen, dass ich nicht doppelt auf die Mail zugreife, sodass er auch im Ordner Test bleibt und nicht im Hauptordner.



```
Dim otl As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim mail As Outlook.MailItem
    Dim f As Long
    Dim letzte As Long
    Dim letzte2 As Long
    Dim ziel As Worksheet
    Dim ziel2 As Worksheet
    Dim olFolder As Object
    Dim olMail As Object
    Dim olApp As Object
    Dim match As Object
    Dim Items As Object

    
    Set olApp = CreateObject("Outlook.Application")
    Set otl = New Outlook.Application
    Set ns = otl.GetNamespace("MAPI")
    Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
    Set mail = fld.Items.GetFirst
    Set ziel = ThisWorkbook.Worksheets("Gesamt Eingang")
    Set ziel2 = ThisWorkbook.Worksheets("Gesamt Ausgang")
    Set olFolder = olApp.ActiveExplorer.CurrentFolder
    
    'RegExp definieren
    Dim rx As Object
    
    Set rx = CreateObject("VBScript.RegExp")
    
    rx.Pattern = "\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)"
    rx.ignoreCase = True
    rx.Global = True
    
    'Prüfen ob der Body eine Tabelle enthält
    If Not rx.test(mail.Body) Then
        MsgBox "Mailbody passt nicht"
        Exit Sub
    End If
    
    For Each olMail In olFolder.Items
        
        If olMail.Subject Like "*Auswertung Resa ausgehende Emails" Then
            
           'Mit dem RegEx die einzelnen Zeilen auslsen
          
           letzte = Sheets("Gesamt Eingang").UsedRange.SpecialCells(xlCellTypeLastCell).Row
                
           For Each match In rx.Execute(mail.Body)
           Set Items = match.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
          
               ziel.Range("A" & letzte).Value = Format(olMail.ReceivedTime, "DD.MM.YYYY") - 1
               ziel.Range("B" & letzte).Value = Items(0)
               ziel.Range("C" & letzte).Value = Items(1)
               ziel.Range("D" & letzte).Value = Items(2)
               ziel.Range("E" & letzte).Value = Items(3)
               ziel.Range("F" & letzte).Value = Items(4)
               ziel.Range("G" & letzte).Value = Items(5)
              
               letzte = letzte + 1
        
           Next match
        
        ElseIf olMail.Subject Like "*Auswertung Resa eingehende Emails" Then
            
        'Mit dem RegEx die einzelnen Zeilen auslsen
        
           letzte2 = Sheets("Gesamt Ausgang").UsedRange.SpecialCells(xlCellTypeLastCell).Row
                
           For Each match In rx.Execute(mail.Body)
           Set Items = match.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
          
               ziel2.Range("A" & letzte2).Value = Format(olMail.ReceivedTime, "DD.MM.YYYY") - 1
               ziel2.Range("B" & letzte2).Value = Items(0)
               ziel2.Range("C" & letzte2).Value = Items(1)
               ziel2.Range("D" & letzte2).Value = Items(2)
               ziel2.Range("E" & letzte2).Value = Items(3)
               ziel2.Range("F" & letzte2).Value = Items(4)
               ziel2.Range("G" & letzte2).Value = Items(5)
              
               letzte2 = letzte2 + 1
        
           Next match
        
        End If
    
        
    Next
```


----------



## Yaslaw (7. Februar 2020)

Copy & Paste ergibt Chaos. Wenn man Codeschnipsel zusammenführt, sollte man die Variabeln anpassen.

Du nimmst mail aus dem Test-folder, prüfst ob der Mailbody passt.
Anschliessend alle Mails aus oFolder durch, was dein aktueller Ordner im Outlook ist.
Arbeiten tust du aber immer nur mit dem einen Mail

Warum?

```
'dein Ablauf gekürzt (kein Code)
Set mail = fld.Items.GetFirst    'Erstes Mail aus C_FOLDER
If Not rx.test(mail.Body) Then ....

Set olFolder = olApp.ActiveExplorer.CurrentFolder
For Each olMail In olFolder.Items  'Also die Mails aus dem offenen Outlookordner, ev der Posteingang
    ...
    If olMail.Subject Like "*Auswertung Resa ausgehende Emails" Then   'Prüfst auf olMail
       For Each match In rx.Execute(mail.Body)   'und nimmst den Body von immer demselben Mail aus, nicht von olMail
```

Entweder arbeitest du mit `mail` oder mit`olMail`. Auf alle Fälle solltest du sie aus `fld`auslesen und nicht aus`olApp....CurrentFolder`.


----------



## jerry0110 (10. Februar 2020)

Yaslaw hat gesagt.:


> Copy & Paste ergibt Chaos. Wenn man Codeschnipsel zusammenführt, sollte man die Variabeln anpassen.
> 
> Du nimmst mail aus dem Test-folder, prüfst ob der Mailbody passt.
> Anschliessend alle Mails aus oFolder durch, was dein aktueller Ordner im Outlook ist.
> ...




Ok, das hat alles funktioniert und ich habe alles jetzt über mail laufen.
Aber er ließt nur eine Mail aus und schreibt sie in das Sheet.

Sobald aber eine 2te Mail im Postfach ist, dann überspringt er quasi das Eintragen der Daten.
Habe schon das Objekt match in match2 geändert, damit die if schleife ein eigenes Objekt hat.
Dazu hab ich geschaut, ob ich mit der msgbox auslesen kann ob er überhaupt den Betreff richtig ausließt. Das macht er auch. Und er springt auf in der if schleife in die richtige Zeile. überspringt dann aber das eintragen.


```
Option Explicit

Public Function xlsGetLastRow(ByRef sheet As Excel.Worksheet) As Long
    Dim r As Variant

    xlsGetLastRow = sheet.Cells.SpecialCells(xlCellTypeLastCell).Row
    For r = xlsGetLastRow To 1 Step -1
        If sheet.Application.WorksheetFunction.CountA(sheet.Rows(r)) = 0 Then
            xlsGetLastRow = r - 1
        Else
            Exit For
        End If
    Next r
End Function

Private Function lastRowNr(ByRef ws As Worksheet)
    lastRowNr = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
End Function


Public Function xlsGetLastCol(ByRef sheet As Excel.Worksheet) As Long
    Dim i As Variant
    xlsGetLastCol = sheet.Cells.SpecialCells(xlCellTypeLastCell).Column
    For i = xlsGetLastCol To 1 Step -1
        If sheet.Application.WorksheetFunction.CountA(sheet.Columns(i)) = 0 Then
            xlsGetLastCol = i - 1
        Else
            Exit For
        End If
    Next i
End Function

Public Sub mailTest()
    Const C_MAPI = "J.Linden@xyz.de"
    Const C_FOLDER = "Test"
   
   
    'Das Test-Mail auslesen
    Dim otl As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim mail As Outlook.MailItem
    Dim f As Long
    Dim letzte As Long
    Dim letzte2 As Long
    Dim ziel As Worksheet
    Dim ziel2 As Worksheet
    Dim olFolder As Object
    Dim olMail As Object
    Dim olApp As Object
    Dim match As Object
    Dim match2 As Object
    Dim Items As Object

   
    Set olApp = CreateObject("Outlook.Application")
    Set otl = New Outlook.Application
    Set ns = otl.GetNamespace("MAPI")
    Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
    Set mail = fld.Items.GetFirst
    Set ziel2 = ThisWorkbook.Worksheets("Gesamt Eingang")
    Set ziel = ThisWorkbook.Worksheets("Gesamt Ausgang")
    Set olFolder = olApp.ActiveExplorer.CurrentFolder
   
    'RegExp definieren
    Dim rx As Object
   
    Set rx = CreateObject("VBScript.RegExp")
   
    rx.Pattern = "\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)"
    rx.ignoreCase = True
    rx.Global = True
   
    'Prüfen ob der Body eine Tabelle enthält
    If Not rx.test(mail.Body) Then
        MsgBox "Mailbody passt nicht"
        Exit Sub
    End If
   
    For Each mail In fld.Items
   
   
        MsgBox mail.Subject
       
        If mail.Subject Like "Auswertung Resa ausgehende Emails" Then
           
           'Mit dem RegEx die einzelnen Zeilen auslsen
         
           letzte = ziel.UsedRange.SpecialCells(xlCellTypeLastCell).Row
               
           For Each match In rx.Execute(mail.Body)
           Set Items = match.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
         
               ziel.Range("A" & letzte).Value = mail.ReceivedTime
               ziel.Range("B" & letzte).Value = Items(0)
               ziel.Range("C" & letzte).Value = Items(1)
               ziel.Range("D" & letzte).Value = Items(2)
               ziel.Range("E" & letzte).Value = Items(3)
               ziel.Range("F" & letzte).Value = Items(4)
               ziel.Range("G" & letzte).Value = Items(5)
             
               letzte = letzte + 1
       
           Next match
       
        ElseIf mail.Subject Like "Auswertung Resa eingehende Emails" Then
           
        'Mit dem RegEx die einzelnen Zeilen auslsen
       
           letzte2 = ziel2.UsedRange.SpecialCells(xlCellTypeLastCell).Row
               
           For Each match2 In rx.Execute(mail.Body)
           Set Items = match2.SubMatches
           '//TODO: Anstelle des debug.print diese in eine neie Zeile eines Excelsheets schreiben
         
               ziel2.Range("A" & letzte2).Value = mail.ReceivedTime
               ziel2.Range("B" & letzte2).Value = Items(0)
               ziel2.Range("C" & letzte2).Value = Items(1)
               ziel2.Range("D" & letzte2).Value = Items(2)
               ziel2.Range("E" & letzte2).Value = Items(3)
               ziel2.Range("F" & letzte2).Value = Items(4)
               ziel2.Range("G" & letzte2).Value = Items(5)
             
               letzte2 = letzte2 + 1
       
           Next match2
       
        End If
   
       
    Next
   
End Sub
```


----------



## jerry0110 (10. Februar 2020)

Ein Zusatz noch. bei der Mail die er dann in das Sheet schreibt passiert folgendes. 
Wenn ich das noch mal durchlaufen lasse, dann schreibt er nicht in die letzte Zeile sonder überschreibt die Zeile davor und trägt dann die Tabelle ab da in das Sheet.


----------



## jerry0110 (11. Februar 2020)

Wenn ich mir den Code noch mal anschaue, dann macht doch die Zeile 70 folgendes. Er sucht nach einer beliebigen Email. Wenn es aber nur 10 gibt die immer gleich sind, dann kann man diese doch fest definieren. Und dann sagen, alles was rechts daneben ist, soll er dann in das Array schreiben. Macht das Sinn?

Muss ich dann RegEx nutzen wenn ich alle Emailadressen weiß?


----------



## Yaslaw (12. Februar 2020)

Chaos, das pure Chaos in deinem Code.
Zeile 70 definiert den Pattern des Regex. Der wählt kein Mail aus. Nix dergleichen.

Warum wählst du am Anfang das erste Mail aus, testest es gegen den Regex und machst weiter nix damit?
Anschliessend gehst du alle Mails durch, wendest den RegEx auf die Mails an ohne sie zu testen.
Dan überschreibt der erste Durchgang logischerweise die letzte Zeile, weil du diese ausliest und anwendest. Wenn du in einer neuen Zeile beginnen willst, dann solltest du die letzte Zeile+1 verwenden

Wozu hast du die Funktionen xlsGetLastCol() und xlsGetLastRow(), wenn du sie nicht brauchst?

Wozu soll oFolder gut sein? Du verwendest ihn nirgends

Wenn du 2 mal denselben Code-Abschnitt hast, dann gehört dieser teil in eine Funktion oder eine Sub.

Hier, das ganze mal aufgeräumt

```
Option Explicit

Public Sub mailTest()
    Const C_MAPI = "stefan.erb@axa-groupsolutions.com"
    Const C_FOLDER = "TEST"
   
    'Das Test-Mail auslesen
    Dim otl As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fld As Outlook.MAPIFolder
    Dim mail As Outlook.MailItem
   
    Set otl = New Outlook.Application
    Set ns = otl.GetNamespace("MAPI")
    Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
   
    For Each mail In fld.Items
        If mail.Subject Like "*Auswertung Resa ausgehende Emails*" Then
            importMail ThisWorkbook.Worksheets("Gesamt Ausgang"), mail
        ElseIf mail.Subject Like "*Auswertung Resa eingehende Emails*" Then
            importMail ThisWorkbook.Worksheets("Gesamt Eingang"), mail
        End If
    Next
End Sub

'/**
' * Importiert ein Mail
' * @param  Worksheet       Zieltabelle, an  die die Daten angefügt werden
' * @param  Mail            Das Mail
' * @return Boolean         True: der Import war erfolgreich
' */'
Private Function importMail(ByRef ioWsZiel As Worksheet, ByRef iMail As Object) As Boolean
    Dim nextRowNr As Long
    Dim match As Object
    Dim Items As Object
    
    'Prüfen ob der Body eine Tabelle enthält
    If Not rxMailBody.test(iMail.body) Then
        MsgBox "Mailbody passt nicht"
        Exit Function
    End If

    nextRowNr = ioWsZiel.UsedRange.SpecialCells(xlCellTypeLastCell).row + 1
       

    For Each match In rxMailBody.Execute(iMail.body)
        Set Items = match.SubMatches
        ioWsZiel.Range("A" & nextRowNr).value = iMail.ReceivedTime
        ioWsZiel.Range("B" & nextRowNr).value = Items(0)
        ioWsZiel.Range("C" & nextRowNr).value = Items(1)
        ioWsZiel.Range("D" & nextRowNr).value = Items(2)
        ioWsZiel.Range("E" & nextRowNr).value = Items(3)
        ioWsZiel.Range("F" & nextRowNr).value = Items(4)
        ioWsZiel.Range("G" & nextRowNr).value = Items(5)
     
        nextRowNr = nextRowNr + 1
    Next match
    importMail = True
End Function

'/**
' * Verwaltet den RegEx
' * @return VBScript.RegExp
' */
Private Property Get rxMailBody() As Object
    Static rx As Object
    If rx Is Nothing Then
        Set rx = CreateObject("VBScript.RegExp")
        rx.Pattern = "\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)"
        rx.ignoreCase = True
        rx.Global = True
    End If
    Set rxMailBody = rx
End Property
```


----------



## jerry0110 (13. Februar 2020)

Yaslaw hat gesagt.:


> Chaos, das pure Chaos in deinem Code.
> Zeile 70 definiert den Pattern des Regex. Der wählt kein Mail aus. Nix dergleichen.
> 
> Warum wählst du am Anfang das erste Mail aus, testest es gegen den Regex und machst weiter nix damit?
> ...




Danke schon mal für deine Hilfe.

Ich habe RegEx noch nie benutzt. Und kenn mich da nicht so aus.
Und weil dort mailto stand, bin ich davon ausgegangen, dass er in der Zeile nach einer Mail sucht.

Also das was nach dem pattern steht sucht quasi nur nach Wörtern und nicht nach Tabellen?
Wenn z. B. die Tabelle nicht 5 sondern nur noch 4 Spalten hat oder 3 dann findet er trotzdem noch alles?

Muss dann aber die importMail Funktion anpassen, dass er quasi nur so viel Items sucht wie auch vorhanden sind?


----------



## Yaslaw (13. Februar 2020)

`\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?`: Mailadresse. Ev  mit dem <mailto:> zusatz. Das sind die Felder, die einen Maillink haben
`\s+(\d+)` Leerzeichen und eine Zahl. Also ein Zahlenfled

Du kannst die Felder auch variabel machen. Also ein Maximum musst du schon definieren
Dazu ersetzt man `\s+(\d+)` durch `(:\s+(\d+))?`. Im folgenden Pattern habe ich jetzt bis zu 7 Felder
`\b([\w.%+-]+@[\w.-]+\.[A-Z]{2,})\b(?: <mailto:[\w.%+-]+@[\w.-]+\.[A-Z]{2,}>)?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?(?:\s+(\d+))?`

Test mit 7 definierten Feldern, aber nur 5 werden geliefert

```
print_r items
<ISubMatches>  (
    [#0] => <String> 'xyz@info.de'
    [#1] => <String> '1557'
    [#2] => <String> '0'
    [#3] => <String> '1557'
    [#4] => <String> '0'
    [#5] => <String> '0'
    [#6] => <Empty> 
    [#7] => <Empty> 
)
```


----------



## jerry0110 (21. Februar 2020)

Hi,

das hat "natürlich alles geklappt".

Was ist denn, wenn bei manchen Emails keine Tabelle vorhanden ist aber trotzdem Werte benutzt werden sollen.

Wir z. B. :



```
Report Zeitraum: 20.02.2020 00:00:00 - 20.02.2020 23:59:59

Total E-mails gesendet : 9

Total E-mails empfangen: 5
```


Wird das dann auch über das Pattern geregelt, dass ich die o. a. Dinge als Array rausbekomme?


----------



## Yaslaw (21. Februar 2020)

Nein. Der Pattern greifft nur die Tabelle ab, sofern sie vorhanden ist
Diese neue Struktur fällt da durch.


----------



## jerry0110 (22. Februar 2020)

Ok. Ich habe das mit Split gelöst.

Aber jetzt sagt er, dass ich ein Objekt brauche und ich verstehe nicht warum.

Und zwar bei 
	
	
	



```
ioWsZiel.Range("A" & nextRowNr).Text = Datum
```



```
Public Sub mailTest2()
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
        .Cursor = xlWait
    End With
     
    Const C_MAPI = "jerry5428@hotmail.com"
    Const C_FOLDER = "Test"

    Dim otl         As Outlook.Application
    Dim ns          As Outlook.Namespace
    Dim fld         As Outlook.MAPIFolder
    Dim mail        As Outlook.MailItem
    Dim lArrayIndex As Variant
    Dim i           As Long
    Dim WrdArray()  As String
    Dim text_string As String
    Dim nextRowNr   As Long
    Dim ioWsZiel    As Worksheet
    Dim iMail       As Object
    Dim Datum       As Date

    Set otl = New Outlook.Application
    Set ns = otl.GetNamespace("MAPI")
    Set fld = ns.Folders(C_MAPI).Folders(C_FOLDER)
    Set ioWsZiel = ThisWorkbook.Worksheets("Gesamt Eingang")

    nextRowNr = ioWsZiel.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1

    For Each mail In fld.Items
 
        Datum = mail.ReceivedTime - 1
        text_string = mail.Body
        WrdArray() = Split(text_string)
     

        If mail.Subject Like "*jerry5428@hotmail.com*" Then
         
            ioWsZiel.Range("A" & nextRowNr).Text = Datum
            ioWsZiel.Range("B" & nextRowNr).Value = "jerry5428@hotmail.com"
            ioWsZiel.Range("C" & nextRowNr).Value = WrdArray(1)
            ioWsZiel.Range("D" & nextRowNr).Value = WrdArray(2)
     
        End If
     
        nextRowNr = nextRowNr + 1
    Next
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .Cursor = xlDefault
    End With
 
End Sub
```


----------



## jerry0110 (22. Februar 2020)

Hab es selber gelöst 

ioWsZiel.Range("A" & nextRowNr).Text = Datum

in 

ioWsZiel.Range("A" & nextRowNr).Value = Datum

geändert


----------



## jerry0110 (24. Februar 2020)

Ich habe doch ein Problem:

Ich habe jetzt mir dem Split den Text getrennt und nutze dann das Array für das Einsetzen der Werte.


```
If mail.Subject Like "*jerry5428@hotmail.com*" Then

            ioWsZiel.Range("A" & nextRowNr).Value = Datum
            ioWsZiel.Range("B" & nextRowNr).Value = "jerry5428@hotmail.com"
            ioWsZiel.Range("C" & nextRowNr).Value = WrdArray(10)
            ioWsZiel.Range("C" & nextRowNr).Value = Replace(Range("C" & nextRowNr).Value, Chr(10), "")
            ioWsZiel.Range("C" & nextRowNr).Value = Trim(Range("C" & nextRowNr).Value)
            ioWsZiel.Range("C" & nextRowNr).Value = Replace(Range("C" & nextRowNr).Value, "Total", "")
            ioWsZiel.Range("C" & nextRowNr).NumberFormat = "0.00"
            ioWsZiel.Range("D" & nextRowNr).Value = WrdArray(13)
            ioWsZiel.Range("D" & nextRowNr).Value = Replace(Range("D" & nextRowNr).Value, Chr(10), "")
            ioWsZiel.Range("D" & nextRowNr).Value = Trim(Range("D" & nextRowNr).Value)
            ioWsZiel.Range("D" & nextRowNr).Value = Replace(Range("D" & nextRowNr).Value, "Total", "")
            ioWsZiel.Range("D" & nextRowNr).NumberFormat = "0.00"
```

Das Problem dabei ist, dass er auch die richtigen Daten einträgt ich diese aber nicht nutzen kann um diese dann in meiner Auswertung zu verwerten. Er erkennt die Werte nicht an.

Wenn ich eine Formel nutze wie z. B. Summenwenns dann erkennt er nicht, dass z. B. an einem bestimmten Datum Werte eingetragen wurden.


----------



## jerry0110 (24. Februar 2020)




----------



## jerry0110 (24. Februar 2020)

Hab jetzt statt Chr(10) vbCrLf genommen. 
Der Umbruch bleibt aber es kommen jetzt Zahlen raus.


----------



## jerry0110 (26. Februar 2020)

Ich hab doch noch ein Problem. Es kommt ab und zu folgender Fehler.


----------



## jerry0110 (26. Februar 2020)

Kann es mit Excel 2016 und Excel 2010 zusammenhängen?


----------



## Yaslaw (26. Februar 2020)

Ist nextRowNr abgefüllt oder Null?
Ist die Zelle gefüllt?
Ist klar, aif welcher Tabelle der Range-Befehl ausgeführt wird?


----------



## jerry0110 (26. Februar 2020)

Wenn ich auf Debug klicke und die Zeile mir angucken dann ist nextRowNr mit "16" gefüllt. 
Wenn ich mit der Maus über das Replace gehe steht da "Fehler 2042"


----------



## Yaslaw (26. Februar 2020)

> Ist die Zelle gefüllt?
> Ist klar, auf welcher Tabelle der Range-Befehl ausgeführt wird?


----------



## jerry0110 (26. Februar 2020)

Die Zelle ist leer wo das eingetragen wird.
Und es ist fest immer Zelle C + die Zeile.

Ich hoffe ich versteh das richtig was du meinst


----------



## Yaslaw (26. Februar 2020)

Du solltest prüfen ob die Zelle Cirgendwas gefüllt ist und nur dann den replace durchführen


----------



## jerry0110 (26. Februar 2020)

Yaslaw hat gesagt.:


> Du solltest prüfen ob die Zelle Cirgendwas gefüllt ist und nur dann den replace durchführen



Die Zellen sind immer gefüllt bevor das Replace kommt.
Ich habe das Makro jetzt per Hand (Schrift für Schritt) durchlaufen lassen.
Da kam der Fehler nicht. 

Folgendes habe ich jetzt getestet. Ich habe einen Button wo das Makro hinterlegt ist.
Dann kommt die Fehlermeldung oder es wird so eingetragen wir das erste Bild.




Dann klicke ich in der Umgebung in den Code und klicke dann auf start und es kommt keine Fehlermeldung und es wird so eingetragen.


----------



## Yaslaw (26. Februar 2020)

Wenn die Zeile mit einem Text befüllt ist, dann würde der replace auch funktionieren.

Was deine 2 Grafiken pezüglich des Replace-Problemes aussagen sollten, habe ich keine Ahnung.


----------



## jerry0110 (26. Februar 2020)

Es ist total komisch. Drück ich auf den Button mit dem gleichen Makro dann kommt die Fehlermeldung und dann macht auch Typ unverträglich Sinn, weil die Zellen da leer sind.

Geh ich in die Entwicklungsumgebung und drücke es per Hand geht alles ohne Probleme


----------



## Yaslaw (26. Februar 2020)

Ich hatte schon mal gefragt. Du verwendest range() ohne angabe einer Tabelle. Bist du sicher, dass das auf die richtige Tabelle zugreift?


----------



## jerry0110 (26. Februar 2020)

Jetzt weiß ich was du meinst....

Ich habe jetzt Source auch noch nach dem gleich genutzt. Und schon kommt die Fehlermeldung nicht mehr.


```
Source.Range("C" & i).Value = Replace(Source.Range("C" & i).Value, "Total", "")
```


----------

