Я борюсь с извлечением имени и адреса электронной почты из стандартной электронной почты.
Я ожидаю более 300 электронных писем с тем же форматом / макетом, как показано ниже.
От: webfeedback@XXXXX.com
Отправлено: четверг, 1 ноября 2018 г., 10:20.
Кому: Джо
Тема: 2018 сертификат КОМАНДЫ
Четверг, 1 ноября 2018 года - 10: 20
Как бы вы хотели, чтобы ваше имя отображалось в СЕРТИФИКАТЕ УЧАСТИЯ? Джо Фамилия
Адрес электронной почты Обязательно ojoelastname@XXXXXXXXX.com
Я хотел бы извлечь имя «Джо Фамилия», адрес электронной почты ojoelastname@xxxxxxxxxx.com и дату, отправленную в Excel.
В настоящее время код извлекается в Excel:
«Как бы вы хотели, чтобы ваше имя отображалось в СЕРТИФИКАТЕ УЧАСТИЯ? OJoe Xaskasdad » и адрес электронной почты «ojoeXaskasdaa@XXXXXXxXxX.org>«
Я изо всех сил пытаюсь выяснить, как получить только Имя " oJoe Xaskasdad " и адрес электронной почты ojoeXaskasdaa@XXXXXXxXxX.org> address (минус ">») .
Я новичок в VBA, но мне нравится учиться. Я нахожусь в тупике, и хотя я продолжаю читать и исследовать ошибку, я надеюсь, что кто-то будет достаточно любезен, чтобы помочь, так как время истекает, и мне, возможно, скоро придется много копировать и вставлять.
Ваши предложения, рекомендации (исправления) будут с благодарностью.
СПАСИБО за любую помощь!
ТЕКУЩИЙ КОД
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