Option Explicit
Sub CopyToExcel()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim oRng As Range
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Dim myTime As String
Const strPath As String = "\\xxxxxxxxx\ixxxxx\XXXX\xxxxx\xxxxxxxx\Auftrag.xlsx"
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Q1 2015")
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Kundennummer:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Tarif") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Eingabedatum") > 0 Then
vItem = Split(vText(i), Chr(58))
myTime = olItem.ReceivedTime
xlSheet.Range("A" & rCount) = myTime
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Widerruf") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("H" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Termin") > 0 Then
vItem = Split(vText(i), Chr(58))
myTime = olItem.ReceivedTime
xlSheet.Range("J" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub