将文本范围/段落从 Outlook 电子邮件导出到 Excel

在搜索之前的一组电子邮件并使用 GMayor 的有用答案后，我有一组新的电子邮件需要导出到 excel.

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;

学生名字:蓝莓

学生邮箱: happyd62@happyemail.com.au

Student Email: happyd62@happyemail.com.au

学生手机号码: 0444444444

Student Mobile Number: 0444444444

您在 2018 年打算做什么?:

附加评论: Blueberry 在过去的一年里并没有每天都去上学，因为她一直在照顾她的兄弟姐妹，并且有一个孩子在路上

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

学生编号: student8

TSF 社区:阿德莱德

请告诉您的赞助商您的爱好、兴趣、家人和朋友: xbox

钩编

编织

家人

跳舞

打嗝

阅读

看电影

去年我引以为豪的一项成就是..:为我的家人编织

你明年选择学习哪些选修科目?:

我想告诉我的赞助商:我喜欢钩编

我遇到的问题是在您将在 2018 年做什么?:"和请告诉您的赞助商..."之后获取信息...在 2018 年做什么?"字段需要在一个单元格中，每行一个.请告诉您的赞助商.."字段需要用逗号分隔.

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.

这两个字段都是可变的.我以为我可以抓住文本2018 年?:"和附加评论:"(独家)之间的所有内容.

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

遵循我使用的脚本；

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

感谢您的帮助.