Exporting range/paragraph of text from Outlook Ema

Question

After searching around and using GMayor's helpful answers on a previous set of emails, I have a new set of emails I need to export into excel.

Following is an example of one such email;

---

Student First Name: Blueberry

Student Email: [e-mail]

Student Mobile Number: 0444444444

What will you be doing in 2018?:

Enrolling in Year 11

Leaving school and seeking employment (work)

Have Caring Responsibilities

Additional Comments: Blueberry hasn't been attending every day at school his past year as she has been caring for her siblings and has a child on the way

Student ID: student8

TSF Community: Adelaide

Please tell your sponsor about your hobbies, interests, family and friends: xbox

crocheting

knitting

family

dancing

hicking

reading

watching movies

An achievement in the last year that I'm proud of is..: knitting for my family

What elective subjects have you chosen to study next year?:

I would like to tell my sponsor: I enjoy crocheting

---

The problem I'm having is grabbing the info after "What will you be doing in 2018?:" and "Please tell your sponsor...". The "..doing in 2018?" field needs to be in a single cell, one per line.. The "Please tell your sponsor.." field needs to be comma separated.

Both these fields are variable. I thought I could grab everything between the texts "in 2018?:" and "Additional Comments:" (exclusive).

Follows in the script I used;

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 vNextA, vNextB, vNextC As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "S:\SSOF1718\SSOF1718-Macro.xlsm" '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("SSOF")

'Process each selected record
 rCount = xlSheet.UsedRange.Rows.Count
  For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
     rCount = rCount + 1
    'Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1
        If InStr(1, vText(i), "Student First Name:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("A" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Student Email:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("B" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Student Mobile Number:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("C" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "What will you be doing in 2018?:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("D" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Additional Comments:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("E" & rCount) = Trim(vItem(1))
        End If

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

        If InStr(1, vText(i), "TSF Community:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("G" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Please tell your sponsor about your hobbies, interests, family and friends:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("H" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "An achievement in the last year that I'm proud of is..:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("I" & rCount) = Trim(vItem(1))
        End If

       If InStr(1, vText(i), "What elective subjects have you chosen to study next year?:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("J" & rCount) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "I would like to tell my sponsor:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("K" & 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

Thanks for your help.

Answer 1

You can use another loop inside the If block for the multiple line answers.

    If InStr(1, vText(i), What will you be doing in 2018?:") > 0 Then

Clear the vItem variable before the loop.

       vItem = ""

Loop from the current line (i) until the end of the array. We will check for the next heading and exit the loop early.

        For ii = i + 1 To UBound(vText)

Assemble the text as needed. Here I add a new line if needed.

           If Trim(vText(ii)) > "" Then 
              If vItem <> "" Then vItem += vbCrLf
              vItem += vText(ii) 
           Emd If 

Check for exit condition.

           If InStr(1, vText(ii), "Additional Comments:") > 0 Then Exit For

        Next ii

Assign to cell.

        xlSheet.Range("D" & rCount) = Trim(vItem)

    End If

Note: I did not test my changes. Please excuse any mistakes and debug as needed.