如何拆分段落并导出到 Excel
How to split paragraph and export to Excel
我正在为一位前老板做一个编码项目，他每年都会收到数百封包含完全相同信息的电子邮件。
我编写了一个代码，帮助将这些电子邮件导出到 excel。但是，今年电子邮件 body 发生了变化。现在它以段落形式包含了一堆信息。
电子邮件如下所示：
Name:
Do you currently reside in the United States?
Address:
City:
State:
Zip Code:
Phone:
Email:
Citizenship:
Grade:
Essay Word Count:
School / Organization Name: Name Teacher Name: Name Teacher Email: 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
加粗的部分是我要的部分
现在我的代码适用于所有内容，除了它似乎无法处理段落部分。
当它导出到 Excel 文档时，它会在 header 中添加下一节 Here is a picture of the spreadsheet. The bold text is being imported correctly, the non-bold text next to it should not be there
我对 VBA 的经验很少，但有一些 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
查看评论/将其与您的代码进行比较 -
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
您有一个已知的模板，它为电子邮件的文本解析提供静态起点和终点 body。我已经将剥离所需值的实际机制放入 'helper' sub.
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
当然，这确实取决于维护传入电子邮件的模板格式 body，但通常这些格式是相当规则的。这里的实际代码很少；大部分文本和 space 被测试字符串和开始和停止 header 值的存储/分配占用。
我正在为一位前老板做一个编码项目，他每年都会收到数百封包含完全相同信息的电子邮件。
我编写了一个代码，帮助将这些电子邮件导出到 excel。但是，今年电子邮件 body 发生了变化。现在它以段落形式包含了一堆信息。
电子邮件如下所示：
Name:
Do you currently reside in the United States?
Address:
City:
State:
Zip Code:
Phone:
Email:
Citizenship:
Grade:
Essay Word Count:
School / Organization Name: Name Teacher Name: Name Teacher Email: 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
加粗的部分是我要的部分
现在我的代码适用于所有内容，除了它似乎无法处理段落部分。
当它导出到 Excel 文档时，它会在 header 中添加下一节 Here is a picture of the spreadsheet. The bold text is being imported correctly, the non-bold text next to it should not be there
我对 VBA 的经验很少，但有一些 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
查看评论/将其与您的代码进行比较 -
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
您有一个已知的模板，它为电子邮件的文本解析提供静态起点和终点 body。我已经将剥离所需值的实际机制放入 'helper' sub.
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
当然，这确实取决于维护传入电子邮件的模板格式 body，但通常这些格式是相当规则的。这里的实际代码很少；大部分文本和 space 被测试字符串和开始和停止 header 值的存储/分配占用。