如何拆分段落并导出到Excel

我正在为前老板编写一个编码项目，每年收到几百份完全相同的电子邮件。

我写了一个代码，帮助将这些电子邮件导出为Excel。 不过，今年电子邮件正文发生了变化。 现在它包含了一些段落forms的信息。

这是电子邮件的样子：

名称：
你目前居住在美国吗？
地址：
市：
州：
邮政编码：
电话：
电子邮件：
国籍：
年级：
散文字数：
学校/组织名称： 姓名教师姓名： 姓名教师电子邮件： 电子邮件您的学校/赞助机构是否在美国？ 学校/组织地址：学校/机构所在城市： 城市学校/组织所在州： 州立学校/组织机构邮政编码： 邮政编码学校/机构电话号码： 电话号码学校/组织电子邮件： 电子邮件您是如何知道本次比赛的？ 答案文件： 互联网链接

大胆的部分是我想要的部分

现在的代码我已经为一切工作，除了它似乎无法处理段落的一部分。

当它导出到Excel文档时，它将添加到下一部分的标题下面是电子表格的图片。 粗体文本正确导入，旁边的非粗体文本不应该在那里

我对VBA有很less的经验，但是有一些python和java的知识。 我知道有一个RegEx选项，但我不知道如何在VBA中使用它们。

有没有办法挽救我的段落代码？

以下是完整的代码：

 Option Explicit Sub CopyToExcel() Dim xlApp As Object Dim xlWB As Object Dim xlSheet As Object Dim olItem As MailItem Dim vText As Variant Dim vPara As Variant Dim sText As String Dim vItem As Variant Dim i As Long Dim aa As Long Dim rCount As Long Dim sLink As String Dim bXStarted As Boolean Const strPath As String = "C:\Users\labuser\Desktop\studentinfo.xlsx" 'the path of the workbook' If Application.ActiveExplorer.Selection.Count = 0 Then MsgBox "No Items selected!", vbCritical, "Error" 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)) vPara = Split(sText, Chr(13)) 'Find the next empty line of the worksheet rCount = xlSheet.UsedRange.Rows.Count 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), "Name:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("A" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Do you current reside in the United States?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("B" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Address:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("C" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Address 2:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("D" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "City:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("E" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "State:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("F" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Zip Code:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("G" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Country:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("H" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Phone:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("I" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Email:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("J" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Citizenship:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("K" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Grade:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("L" & rCount) = Trim(vItem(1)) End If If InStr(1, vText(i), "Essay Word Count:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("M" & rCount) = Trim(vItem(1)) End If Next i For aa = UBound(vPara) To 0 Step -1 If InStr(1, vPara(aa), "School / Organization Name: ") > 0 Then vText = Split(vPara(aa), Chr(58)) xlSheet.Range("N" & rCount) = Trim(Replace(vItem(1), "School / Organization Name: ", "")) xlSheet.Range("O" & rCount) = Trim(Replace(vText(2), "Teacher Name: ", "")) xlSheet.Range("P" & rCount) = Trim(Replace(vText(3), "Teacher Email: ", "")) xlSheet.Range("Q" & rCount) = Trim(Replace(vText(4), " Is your school / sponsoring organization based in the United States?", "")) xlSheet.Range("R" & rCount) = Trim(Replace(vText(5), " School / Organization Address: ", "")) xlSheet.Range("S" & rCount) = Trim(Replace(vText(6), " School / Organization City: ", "")) xlSheet.Range("T" & rCount) = Trim(Replace(vText(7), " School / Organization State: ", "")) xlSheet.Range("U" & rCount) = Trim(Replace(vText(8), " School / Organization Zip Code: ", "")) xlSheet.Range("V" & rCount) = Trim(Replace(vText(9), " School / Organization Phone: ", "")) xlSheet.Range("W" & rCount) = Trim(Replace(vText(10), " School / Organization Email: ", "")) End If Next aa 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

看到评论/比较你的代码 –

 Option Explicit Sub CopyToExcel() Dim xlApp As Excel.Application Dim xlWB As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim olItem As Outlook.MailItem Dim vText As Variant Dim sText As String Dim vItem As Variant Dim i As Long Dim RowCount As Long Dim sLink As String Dim bXStarted As Boolean Dim FilePath As String Dim sReplace As String FilePath = "C:\Temp\Book1.xlsx" 'the path of the xl workbook' If Application.ActiveExplorer.Selection.Count = 0 Then MsgBox "No Items selected!", vbCritical, "Error" 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(FilePath) ' Open xlFile Set xlSheet = xlWB.Sheets("Sheet1") ' use Sheet1 or Sheet name '// Process each selected Mail Item For Each olItem In Application.ActiveExplorer.Selection sText = olItem.body ' Email Body vText = Split(sText, Chr(13)) ' Chr(13) = Carriage return ' vPara = Split(sText, Chr(13)) '// Find the next empty line of the worksheet RowCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row RowCount = RowCount + 1 '// Check each line of text in the message body down loop For i = UBound(vText) To 0 Step -1 '// InStr([start,]mainString, SearchedString[, compare]) If InStr(1, vText(i), "Name:") > 0 Then '// Split vItem : & : vItem = Split(vText(i), Chr(58)) ' Chr(58) = : '// Trim = String whose both side spaces needs to be trimmed xlSheet.Range("A" & RowCount) = Trim(vItem(1)) ' (1) = Position End If '// Do you current reside in the United States? If InStr(1, vText(i), "Do you current reside in the United States?") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("B" & RowCount) = Trim(vItem(1)) End If '// Address: If InStr(1, vText(i), "Address:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("C" & RowCount) = Trim(vItem(1)) End If '// Address 2: If InStr(1, vText(i), "Address 2:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("D" & RowCount) = Trim(vItem(1)) End If '// City: If InStr(1, vText(i), "City:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("E" & RowCount) = Trim(vItem(1)) End If '// State: If InStr(1, vText(i), "State:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("F" & RowCount) = Trim(vItem(1)) End If '// Zip Code: If InStr(1, vText(i), "Zip Code:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("G" & RowCount) = Trim(vItem(1)) End If '// Country: If InStr(1, vText(i), "Country:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("H" & RowCount) = Trim(vItem(1)) End If '// Phone: If InStr(1, vText(i), "Phone:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("I" & RowCount) = Trim(vItem(1)) End If '// Email: If InStr(1, vText(i), "Email:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("J" & RowCount) = Trim(vItem(1)) End If '// Citizenship: If InStr(1, vText(i), "Citizenship:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("K" & RowCount) = Trim(vItem(1)) End If '// Grade: If InStr(1, vText(i), "Grade:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("L" & RowCount) = Trim(vItem(1)) End If '// Essay Word Count: If InStr(1, vText(i), "Essay Word Count:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("M" & RowCount) = Trim(vItem(1)) End If '// School / Organization Name If InStr(1, vText(i), "School / Organization Name:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("N" & RowCount) = Trim(Replace(vItem(1), "Teacher Name", "")) End If '// Teacher Name If InStr(1, vText(i), "Teacher Name:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("O" & RowCount) = Trim(Replace(vItem(2), "Teacher Email", "")) End If '// Teacher Email If InStr(1, vText(i), "Teacher Email:") > 0 Then vItem = Split(vText(i), Chr(32)) xlSheet.Range("P" & RowCount) = Trim(vItem(10)) End If '// Is your school / sponsoring organization based in the United States? If InStr(1, vText(i), "Is your school / sponsoring organization based in the United States?") > 0 Then vItem = Split(vText(i), Chr(32)) 'Chr(32) = space xlSheet.Range("Q" & RowCount) = Trim(vItem(22)) End If '// School / Organization Address: If InStr(1, vText(i), "School / Organization Address:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("R" & RowCount) = Trim(Replace(vItem(4), "School / Organization City", "")) End If '// School / Organization City: If InStr(1, vText(i), "School / Organization City:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("S" & RowCount) = Trim(Replace(vItem(5), "School / Organization State", "")) End If '// School / Organization State: If InStr(1, vText(i), "School / Organization State:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("T" & RowCount) = Trim(Replace(vItem(6), "School / Organization Zip Code", "")) End If '// School / Organization Zip Code: If InStr(1, vText(i), "School / Organization Zip Code:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("U" & RowCount) = Trim(Replace(vItem(7), "School / Organization Phone", "")) End If '// School / Organization Phone: If InStr(1, vText(i), "School / Organization Phone:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("V" & RowCount) = Trim(Replace(vItem(8), "School / Organization Email", "")) End If '// School / Organization Email: If InStr(1, vText(i), "School / Organization Email") > 0 Then vItem = Split(vText(i), Chr(32)) xlSheet.Range("W" & RowCount) = Trim(vItem(56)) End If '// How did you find out about this contest? If InStr(1, vText(i), "How did you find out about this contest?") > 0 Then vItem = Split(vText(i), Chr(32)) xlSheet.Range("X" & RowCount) = Trim(vItem(65)) End If '// Essay Document: If InStr(1, vText(i), "Essay Document:") > 0 Then vItem = Split(vText(i), Chr(58)) xlSheet.Range("Y" & RowCount) = Trim(vItem(10)) End If Next i xlWB.Save Next olItem '// Save & close workbook xlWB.Close SaveChanges:=True If bXStarted Then xlApp.Quit End If '// Cleanup Set xlApp = Nothing Set xlWB = Nothing Set xlSheet = Nothing Set olItem = Nothing End Sub 

Answer 2

您有一个已知的模板，为电子邮件正文的文本parsing提供静态的开始和停止点。 我已经把剥离出所需值的实际机制转化为“帮手”。

 Option Explicit Public Const testString As String = "Name: Do you currently reside in the United States? " & _ "Address: City: State: Zip Code: Phone: Email: Citizenship: Grade: Essay Word Count: " & _ "School / Organization Name: SO Name Teacher Name: T Name Teacher Email: T Email " & _ "Is your school / sponsoring organization based in the United States? Answer " & _ "School / Organization Address: Address School / Organization City: City School / " & _ "Organization State: State School / Organization Zip Code: Zip Code School / Organization " & _ "Phone: Phone Number School / Organization Email: Email How did you find out about this " & _ "contest? Answer Essay Document: internet link" Sub main() Dim v As Long, vVALs As Variant 'Somewhere here you get the body of the email 'I am using the sample string you provided in 'your question made into a public string above. parseEmail testString, vVALs 'for testing purposes 'For v = LBound(vVALs) To UBound(vVALs) ' Debug.Print vVALs(v) 'Next v With Worksheets("Sheet1") With .Cells(Rows.Count, "N").End(xlUp) .Resize(1, UBound(vVALs) + 1).Offset(1, 0) = vVALs Erase vVALs End With End With End Sub Sub parseEmail(ByVal str As String, ByRef pcs As Variant) Dim tmp As String, v As Long, vSRTs As Variant, vSTPs As Variant vSRTs = Array("School / Organization Name: ", "Teacher Name: ", "Teacher Email: ", _ "organization based in the United States? ", "School / Organization Address: ", _ "School / Organization City: ", "School / Organization State: ", _ "School / Organization Zip Code: ", "School / Organization Phone: ", _ "School / Organization Email: ", "find out about this contest? ", _ "Essay Document: ") vSTPs = Array(" Teacher", " Teacher", " Is your school", " School / Or", " School / Or", _ " School / Or", " School / Or", " School / Or", " School / Or", _ " How did you find", " Essay ") For v = LBound(vSRTs) To UBound(vSRTs) - 1 str = Mid$(str, InStr(1, str, vSRTs(v), vbTextCompare) + Len(vSRTs(v))) tmp = tmp & Left$(str, InStr(1, str, vSTPs(v), vbTextCompare) - 1) & ChrW(8203) Next v str = Mid$(str, InStr(1, str, vSRTs(v), vbTextCompare) + Len(vSRTs(v))) tmp = tmp & str pcs = Split(tmp, ChrW(8203)) End Sub 

当然，这取决于维护传入电子邮件主体的模板格式，但通常这些都是相当规范的。 这里的代码非常less。 大部分的文本和空间被testingstring和起始和停止标题值的存储/分配占用。