title: How to extract specific text from emails?
body: <p>I am struggling with extracting a name and email address from a form email.</p>
  <p>I expect over 300 emails with the format/layout below.</p>
  <pre class="lang-none prettyprint-override"><code>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
  </code></pre>
  <p>I would like to extract the name “Joe LastName”, the email address ojoelastname@xxxxxxxxxx.com and the date submitted into Excel.</p>
  <p>The code is extracting:<br />
  &quot;How would you like your name to appear on the CERTIFICATE OF PARTICIPATION? <strong>OJoe Xaskasdad</strong>&quot; and the email address  &quot;<strong>ojoeXaskasdaa@XXXXXXxXxX.org&gt;</strong>&quot;</p>
  <p>How do I get the Name &quot;<strong>oJoe Xaskasdad</strong>&quot; and the email address <strong>ojoeXaskasdaa@XXXXXXxXxX.org</strong> (minus ”&gt;”)?</p>
  <pre><code>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 = &quot;D:\My Documents\Book1.xlsx&quot; 'the path of the xl workbook'
  
      If Application.ActiveExplorer.Selection.Count = 0 Then
          MsgBox &quot;No Items selected!&quot;, vbCritical, &quot;Error&quot;
      End If
  
      On Error Resume Next
      Set xlApp = GetObject(, &quot;Excel.Application&quot;)
  
      If Err &lt;&gt; 0 Then
          Application.StatusBar = &quot;Please wait while Excel source is opened ... &quot;
          Set xlApp = CreateObject(&quot;Excel.Application&quot;)
          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(&quot;Sheet1&quot;) ' 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(&quot;A&quot; &amp; 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), &quot;name to appear&quot;) &gt; 0 Then
                  '// Split vItem : &amp; :
                  vItem = Split(vText(i), Chr(58)) ' Chr(58) = :
                  '// Trim = String whose both side spaces needs to be trimmed
                  xlSheet.Range(&quot;A&quot; &amp; RowCount) = Trim(vItem(0)) ' (0) = Position
              End If
  
              '// Email Address Required
              If InStr(1, vText(i), &quot;Email Address Required &quot;) &gt; 0 Then
                  vItem = Split(vText(i), Chr(58))
                  xlSheet.Range(&quot;B&quot; &amp; RowCount) = Trim(vItem(1))
              End If
  
          Next i
  
          xlWB.Save
  
      Next olItem
  
      '// Save &amp; 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
  </code></pre>