Daten aus Mails nach Excel exportieren

[mumpel]

Kann ich nicht nachvollziehen. Da müsste ich reinschauen können (heute nicht mehr, muss zur Spätschicht).

[Kreck2]

Hallo mumpel,
mach erstmal Deine Schicht. Reinschauen kannst Du ggf. über TeamViewer.

Gruß Kreck2

[mumpel]

Problem gelöst (per Fernkonferenz).

[mumpel]

Hier noch der Code, für alle die es interessiert.

Option Explicit

Public Sub UebertragAntragTest()

Dim olApp           As Outlook.Application
Dim olName          As Outlook.NameSpace
Dim olFolderStart   As Outlook.MAPIFolder
Dim olFolderEnd     As Outlook.MAPIFolder

Dim xlApp           As Excel.Application
Dim xlBook          As Excel.Workbook
Dim xlSheet         As Excel.Worksheet

Dim olFolderItems   As Long

Dim strNewSubject   As String
Dim vntTempArray    As Variant
Dim lngTextToVal    As Long
Dim lngZeileFzArt   As Long

Dim xlRange         As Long
Dim lngFZCount      As Long



Set olApp = Application
Set olName = olApp.GetNamespace("MAPI")
Set olFolderStart = olName.Session.Folders("RMH Software").Folders("Posteingang").Folders("Ticket-System")
Set olFolderEnd = olName.Session.Folders("RMH Software").Folders("Posteingang").Folders("Ticket-System").Folders("Erledigt")
    
    
Set xlApp = New Excel.Application
    With xlApp
        .Visible = True
        .Workbooks.Open Environ("USERPROFILE") & "\Desktop\Moped2015.xlsb"
         Set xlBook = xlApp.Workbooks("Moped2015.xlsb")
         Set xlSheet = xlBook.Sheets("Import Jürgen")
             With xlBook
                  With xlSheet
                       For olFolderItems = olFolderStart.Items.Count To 1 Step -1
                           strNewSubject = Replace(olFolderStart.Items(olFolderItems).Subject, _
                                                   "[ACHTUNG! Absenderadresse kann gefaelscht sein - bitte ueberpruefen!] ", "")
                           strNewSubject = Replace(strNewSubject, "(", "")
                           strNewSubject = Replace(strNewSubject, ")", "")
                           If Mid(strNewSubject, 1, 9) = "Ticket_ID" Then
                              vntTempArray = Split(olFolderStart.Items(olFolderItems).Body, vbCrLf)
                              lngTextToVal = Val(Mid(vntTempArray(40), 9, 1))
                              lngZeileFzArt = 15
                              For lngFZCount = 1 To lngTextToVal
                                  xlRange = _
                                   .Range("A" & .Rows.Count).End(xlUp).Row + 1
                                   .Range("A" & xlRange) = olFolderStart.Items(olFolderItems).SentOn
                                   .Range("B" & xlRange) = strNewSubject
                                   .Range("D" & xlRange) = lngTextToVal
                                   .Range("E" & xlRange) = Replace(vntTempArray(5), "Anrede:           ", "")
                                   .Range("F" & xlRange) = Replace(vntTempArray(6), "Name:             ", "")
                                   .Range("G" & xlRange) = Replace(vntTempArray(7), "Vorname:          ", "")
                                   .Range("H" & xlRange) = Replace(vntTempArray(8), "Geburtstag:       ", "")
                                   .Range("I" & xlRange) = Replace(vntTempArray(9), "Strasse:          ", "")
                                   .Range("J" & xlRange) = Replace(vntTempArray(10), "Plz:              ", "")
                                   .Range("K" & xlRange) = Replace(vntTempArray(11), "Ort:              ", "")
                                   .Range("L" & xlRange) = Replace(vntTempArray(12), "Mail_wiederholt: ", "")
                                   .Range("M" & xlRange) = Replace(vntTempArray(13), "alter1:           ", "")
                                   .Range("N" & xlRange) = Replace(vntTempArray(14), "Telefon:          ", "")
                                   .Range("O" & xlRange) = Replace(vntTempArray(lngZeileFzArt), "fahrzeug_art" & lngFZCount & ":    ", "")
                                   .Range("P" & xlRange) = Replace(vntTempArray(lngZeileFzArt + 1), "fahrzeug_hersteller" & lngFZCount & ": ", "")
                                   .Range("Q" & xlRange) = Replace(vntTempArray(lngZeileFzArt + 2), "fahrzeug_schlüssel" & lngFZCount & ": ", "")
                                   .Range("R" & xlRange) = Replace(vntTempArray(lngZeileFzArt + 3), "fahrzeug_datum" & lngFZCount & ":  ", "")
                                   .Range("S" & xlRange) = Replace(vntTempArray(lngZeileFzArt + 4), "vorvertrag" & lngFZCount & ":      ", "")
                                   .Range("U" & xlRange) = Replace(vntTempArray(35), "angebot:          ", "")
                                   .Range("V" & xlRange) = Replace(vntTempArray(36), "beratung:         ", "")
                                   .Range("W" & xlRange) = Replace(vntTempArray(37), "zustimmung:       ", "")
                                   .Range("T" & xlRange) = Mid(vntTempArray(44), 14, 4)
                                    lngZeileFzArt = lngZeileFzArt + 5
                              Next lngFZCount
                           End If
                           olFolderStart.Items(olFolderItems).Move olFolderEnd
                       Next olFolderItems
                  End With
                 .Save
                 .Close
             End With
            .Quit
    End With
End Sub

VBA/HTML - CodeConverter für Office-Foren, AddIn für Office 2002-2013 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:mumpel
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

[Kreck2]

Mumpel ist genial!
Danke!