Copying text after a Carrage Return from Outlook 2010 Message Body to Excel

Good Afternoon

I am seeking some advice on trying to export text from a mail message to excel. I have found some scripts online which does the jobs when there is an idenfier which proceeds the text I require to export, but in the case where the text is on the line which is below the identifer I cannot seem to find away to copy the text and export it.

I have been able to split the First name and last name and the Product, Order Date, and order name

Here is the body of the message, I would need to take the Delivery Address on the line below the text Delivery Address


The following product(s) has been purchased:


Customer: Pepper Pots - emailaddressatcouk

Qty: 1 STAFF6mA 2013/14 - Six-Month Parking Permit (Staff A) 2013/14

Dispatch Address:

Delivery Address

Somewhere, Else, Gloucestershire, GL0 000, United Kingdom

Your item was included as part of the following order:

Order date: 25/06/2014 13:55:54
Order Number: FFFFFFFFFFF

Here is the existing Code that I have

Option Explicit
Sub openExcel()
Dim xlApp As Object
Dim sourceWB As Workbook
Dim sourceWS As Worksheet
Dim strFile As String
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim vItema As Variant
Dim i As Long
Dim oRng As Range
Dim rCount As Long
Dim bXStarted As Boolean
Dim Customer As String
Dim CustomerFirstName As String
Dim CustomerLastName As String
Dim StaffStudentCode As String
Dim DeliveryAddress As String
Dim DeliveryAddressexport As String
Dim Product As String
Dim vehicleregistration As String
Dim makemodelcolour As String

'And so on . . .. .
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With

strFile = "C:\Users\securityfch\Test.xlsx"
bXStarted = True
Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
Set sourceWS = sourceWB.Worksheets("Sheet1")
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))

rCount = sourceWS.Range("A" & sourceWS.Rows.Count).End(xlUp).Row
rCount = rCount + 1

For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Customer: ") > 0 Then
Customer = Replace(vText(i), "Customer: ", "")
'loses the email address
Customer = Left(Customer, InStr(Customer, "-") - 1)
CustomerFirstName = Left(Customer, InStr(Customer, " "))
CustomerLastName = Right(Customer, InStr(Customer, " "))
sourceWS.Range("A" & rCount) = Trim(CustomerFirstName)
sourceWS.Range("B" & rCount) = Trim(CustomerLastName)

End If

If InStr(1, vText(i), "Delivery Address") > 0 Then
DeliveryAddress = Replace(vText(i), "Delivery Address", Chr(10))
DeliveryAddress = Right(DeliveryAddress, InStr(DeliveryAddress, Chr(10)) - 1)
sourceWS.Range("C" & rCount) = Trim(DeliveryAddress)
End If
'If Left(vText(i), 8) = "Question" Then
' If InStr(1, vText(i), "Student or Staff Number") > 0 Then
' rCount = rCount + 1 'so read the next line . . . . .
' StaffStudentCode = Replace(vText(i), "Answer:", " ")
' ElseIf InStr(1, vText(i), "vehicle registration") > 0 Then
' rCount = rCount + 1 'so read the next line . . . . .
' vehicleregistration = Replace(vText(i), "Answer :", " ")
' ElseIf InStr(1, vText(i), "make,model and colour") > 0 Then
' rCount = rCount + 1 'so read the next line . . . . .
' makemodelcolour = Replace(vText(i), "Answer :", " ")

' End If
'End If

If InStr(1, vText(i), "Product :") > 0 Then
vItem = Split(vText(i), Chr(58))
sourceWS.Range("F" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "Order date:") > 0 Then
vItem = Split(vText(i), Chr(58))
sourceWS.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Order Number:") > 0 Then
vItem = Split(vText(i), Chr(58))
sourceWS.Range("E" & rCount) = Trim(vItem(1))
End If
Next i
'Now set all of the fields

'sourceWS.Range("C" & rCount) = Trim(StaffStudentCode)
'sourceWS.Range("D" & rCount) = Trim(DeliveryAddress)
'sourceWS.Range("E" & rCount) = Trim(vehicleregistration)
'sourceWS.Range("F" & rCount) = Trim(makemodelcolour)
'sourceWS.Range("G" & rCount) = Trim(CustomerLastName)

sourceWB.Save
Next olItem
sourceWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set sourceWB = Nothing
Set sourceWS = Nothing
Set olItem = Nothing
End Sub

Any help would be appricated

Thank you