Need to extract from data from email body into Excel - vba

Question

I'm a complete coding novice and I'm struggling with extracting the data out of an email bodies into an Excel 2010 sheet.
The format of the email is;
Form Response
First name John
Surname Smith
Email john.smith#test.com.au
Today's code word test1
I'v been trying my luck at various bits of VBA code I've found online however end up with Subscript out of Range errors when ever it gets to the body of the email;
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "c:\test\test1.xlsx" 'the path of the workbook
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
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.UsedRange.Rows.Count
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
rCount = rCount + 1
If InStr(1, vText(i), "First name ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Surname:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Email:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Today's code word ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
Can anyone offer any help?
Thanks.

Answer 1

i think the Problem is caused by the use of the split-function.
Try this:
fist you need additionally
dim mystart as integer
dim myend as integer
and the delete everything with "vtext" and alter your code like this:
If InStr(1, sText, "First name ") > 0 Then
mystart = InStr(1, sText, "First name ") + 11
myend = InStr(mystart, sText, Chr(10)) - mystart - 1
vItem = mid(sText, mystart, myend)
xlSheet.Range("A" & rCount) = Trim(vItem)
End If
Hope this helps,
Max

Answer 2

What line of code throws an exception? Did you try to debug the code?
I'd recommend starting from the Getting Started with VBA in Outlook 2010 article. Also please remember that indexes start from 1, not 0.