Question

在上一组电子邮件中搜索并使用GMayor的有用答案后，我需要将一组新的电子邮件导出到excel中。

以下是一封此类电子邮件的示例;

学生名：蓝莓

学生电邮： happyd62@happyemail.com.au

学生手机号码： 0444444444

你将在2018年做什么？：

报名参加11年级

离开学校就业（工作）

有爱心责任

补充评论：蓝莓过去一年没有在学校每天参加，因为她一直在照顾她的兄弟姐妹并且还有一个孩子在路上

学生证： student8

TSF社区：阿德莱德

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

钩编

针织

家族

跳舞

hicking

读

看电影

去年我为之骄傲的成就是......：为我的家人编织

你选择明年学习哪些选修科目？：

我想告诉我的赞助商：我喜欢编织

我遇到的问题是在“你将在2018年做什么？：”和“请告诉你的赞助商......”之后抓住这些信息。 “......在2018年？”字段需要在一个单元格中，每行一个..“请告诉你的赞助商......”字段需要以逗号分隔。

这两个字段都是可变的。我以为我可以在“2018年？”和“附加评论：”（独家）的文本之间抓取所有内容。

跟随我使用的脚本;

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

感谢您的帮助。

Answer 1

您可以在If块中使用另一个循环来获得多行答案。

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

在循环之前清除vItem变量。

       vItem = ""

从当前行（i）循环直到数组结束。我们将检查下一个标题并提前退出循环。

        For ii = i + 1 To UBound(vText)

根据需要组合文本。如果需要，我在这里添加一个新行。

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

检查退出条件。

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

        Next ii

分配到单元格。

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

    End If

注意：我没有测试我的更改。请原谅任何错误并根据需要进行调试。

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

1 个答案: