Microsoft Excel

Herbers Excel/VBA-Archiv

Email Text durchsuchen, Zeilen nach Excel kopieren


Betrifft: Email Text durchsuchen, Zeilen nach Excel kopieren von: Kaspar Kann
Geschrieben am: 28.01.2019 15:44:47

Hallo zusammen,

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!

  

Betrifft: AW: Email Text durchsuchen, Zeilen nach Excel kopieren von: MCO
Geschrieben am: 29.01.2019 07:05:50

Guten Morgen!

An deiner Stelle würde ich vieleicht mit SPLIT arbeiten um alle Datensätze zu erfassen.

Hintergrund: Alle Zeilen sind durch einen Zeilenumbruch getrennt. wenn du du "strBody" danach unterteilst hast du jede Menge Zeilen für deinen durchlauf, die du auch wiederum nach Leerstellen trennen kannst, statt nach festen spaltenbreiten.

    zeil_arr = Split(strBody, Chr(10)) 'Trennen nach Umbruch (evtl chr(32))
    
    For zeile = 0 To UBound(zeil_arr)
        i = zeile + 1
        zeile_teil_arr = Split(zeil_arr(zeile), " ") 'Trennen nach Leerzeichen
        
        Range("Release").Offset(i, 0) = zeile_teil_arr(0)
        Range("Schedule").Offset(i, 0) = zeile_teil_arr(1)
        Range("Part_Number").Offset(i, 0) = zeile_teil_arr(2)
        Range("Quantity").Offset(i, 0) = zeile_teil_arr(3)
        Range("First_req_Date").Offset(i, 0) = zeile_teil_arr(4)
        Range("Ship_To").Offset(i, 0) = zeile_teil_arr(5)
    Next zeile
Gruß, MCO


Beiträge aus dem Excel-Forum zum Thema "Email Text durchsuchen, Zeilen nach Excel kopieren"