【发布时间】：2023-03-20 15:45:01
【问题描述】：
我正在努力从表单电子邮件中提取姓名和电子邮件地址。
我预计会收到超过 300 封格式/布局如下的电子邮件。
From: webfeedback@XXXXX.com
Sent: Thursday, November 01, 2018 10:20 AM
To: Joe
Subject: 2018 TEAM Certificate
Thursday, November 1, 2018 - 10:20
How would you like your name to appear on the CERTIFICATE OF PARTICIPATION? Joe LastName
Email Address Required ojoelastname@XXXXXXXXX.com
我想提取姓名“Joe LastName”、电子邮件地址 ojoelastname@xxxxxxxxxx.com 和提交到 Excel 中的日期。
代码正在提取：
“您希望您的名字如何出现在参与证书上？OJoe Xaskasdad”和电子邮件地址“ojoeXaskasdaa@XXXXXXxXxX.org>”
如何获得名称“oJoe Xaskasdad”和电子邮件地址 ojoeXaskasdaa@XXXXXXxXxX.org（减号“>”）？
Sub CopyToExcel13()
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 = "D:\My Documents\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 to appear") > 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(0)) ' (0) = Position
End If
'// Email Address Required
If InStr(1, vText(i), "Email Address Required ") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & RowCount) = Trim(vItem(1))
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
【问题讨论】：
-
Regex 将是一个很好的添加标签，因为这将是获得您想要的东西的好方法。 @ 符号可以在正文中出现多次吗？总是 .org 吗？
-
完成 - 谢谢！
-
该代码需要一种格式，其中一行包含一个标签，然后是一个冒号字符，然后是您想要的文本。放一个：后？符合 CERTIFICATE OF PARTICIPATION 吗？和 Split 应该将行分成两部分，你应该得到“Joe LastName”。
-
如果 Niton 的回答解决了您的问题，您应该通过单击其顶部附近的勾号来接受它。
标签： regex vba split outlook trim