Excel VBA - Emailbody aus Outlook auslesen


jerry0110

Erfahrenes Mitglied
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.

Visual Basic:
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.


Visual Basic:
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

n/a
Moderator
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?
Visual Basic:
'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

Erfahrenes Mitglied
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?
Visual Basic:
'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.

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.

Visual Basic:
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

Erfahrenes Mitglied
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

Erfahrenes Mitglied
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

n/a
Moderator
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
Visual Basic:
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

Erfahrenes Mitglied
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
Visual Basic:
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

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?
 
Zuletzt bearbeitet:

Yaslaw

n/a
Moderator
  • \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
Code:
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

Erfahrenes Mitglied
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. :


Code:
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?
 

jerry0110

Erfahrenes Mitglied
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
Code:
ioWsZiel.Range("A" & nextRowNr).Text = Datum

Visual Basic:
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
 
Zuletzt bearbeitet:

jerry0110

Erfahrenes Mitglied
Hab es selber gelöst :D

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

in

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

geändert :cool:
 

jerry0110

Erfahrenes Mitglied
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.

Visual Basic:
        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.
 
Zuletzt bearbeitet:

Yaslaw

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

jerry0110

Erfahrenes Mitglied
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"