Email Text durchsuchen, Zeilen nach Excel kopieren
28.01.2019 15:44:47
Kaspar
meine Aufgabe ist es, ein Excel Makro zu erstellen, der den Inhalt automatisch generierter Emails durchsucht und die entsprechenden Zeilen in eine Excel Tabelle kopiert.
Die Email beinhaltet eine vermeintliche Tabelle, die jedoch nur durch Kommas getrennter Fließtext ist. Die Anzahl der Einträge varieren.
Die Excel Tabelle soll ähnlich aussehen, jedoch sollen die Werte der Email in die entsprechenden Zellen aufgeteilt werden.
Mein Code sieht bisher so aus und funktioniert aber nur für eine Zeile. Mir fehlt ein Schleife, um das ganze mehrfach durchzuführen. Allerdings bin ich auch nach einiger Recherche zu keinem Ergebnis gekommen.
Sub EmailExtract ()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namesapce
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim strBody As String
Dim strFind As String
Dim strColX, strColA, strColB, strColC, strColD, strColE As String
Dim xlSheet As Object
Dim itm As Object
Dim i As Integer
Dim sFilterStart As String
Dim sFilterEnd As String
Dim sExtract As String
Dim aExtract () As String
Dim aExtractItems () As String
Set OutloopApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("TEST")
i = 1
On Error Resume Next
rCount = xlSheet.Range("A" & xlSheetl.Rows.Count).End(-4162).Row
rCount = rCount + 1
Worksheets("Sheet1").Range("A6:E250".ClearContents
For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_Date").Value Then
strBody = OutlookMail.Body
strFind"368"
strColx = Mid(strBody, InStr(1, strBody, strFind, 1))
strColx = Left(strColx, 66)
stColA = Left(strColx, 8)
strColA = LTrim(strColA)
strColA = RTrim(strColA)
stColB = Left(strColx, 10, 10)
strColB = LTrim(strColB)
strColB = RTrim(strColB)
stColC = Left(strColx, 20, 20)
strColC = LTrim(strColC)
strColC = RTrim(strColC)
stColD = Left(strColx, 45, 10)
strColD = LTrim(strColD)
strColD = RTrim(strColD)
stColE = Left(strColx, 56, 11)
strColE = LTrim(strColE)
strColE = RTrim(strColE)
strFind = "Ship to"
strColF = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColF = Left(strColF, InStr(strColF, vbLf) -1)
Range("Release").Offset(i, 0).Value = stColA
Range("Schedule").Offset(i, 0).Value = stColB
Range("Part_Number").Offset(i, 0).Value = stColC
Range("Quantity").Offset(i, 0).Value = stColD
Range("First_req_Date").Offset(i, 0).Value = stColE
Range("Ship_To").Offset(i, 0).Value = stColF
i = i + 1
End If
Next OutlookMail
Set Folder = Nothing
Set OutlookNameSpace = Nothing
Set OutlookApp = Nothing
End Sub
Ich hoffe, ihr habt alle benötigten Infos. Es ist das erste Mal, dass ich hier poste.
Vielen Dank im Voraus!