Excel VBA Copy Certain Text From Email Body

[Sajjad Haider]

I found the below code in this website that copies the email body from a specified folder in outlook and pastes it to excel. However, the problem is I want a specific text only to be copied to excel. I inserted the email sample and I want the highlighted item to be copied.

Hi,

@ Build: please add the following fixings in System(for 24-Dec-2018):

123456_ABC_Goal --- 123456789.20

123456_ABC_RiskFee --- 123456789.88

Thanks

Option Explicit
Public gblStopProcessing As Boolean
Sub ParseBlockingSessionsEmailPartOne()
' This macro requires Microsoft Outlook Object Library (Menu: Tools/References) be available
Dim wb As Workbook
Dim ws As Worksheet
Dim objFolder As Object
Dim objNSpace As Object
Dim objOutlook As Outlook.Application
Dim lngAuditRecord As Long
Dim lngCount As Long
Dim lngTotalItems As Long 'Count of emails in the Outlook folder.
Dim lngTotalRecords As Long
Dim i As Integer
Dim EmailCount As Integer 'The counter, which starts at zero.
'
  On Error GoTo HandleError
  'Application.ScreenUpdating = True
  'Application.ScreenUpdating = False
'
Sheets("Merge Data").Select
'
  ' Initialize:
  Set wb = ThisWorkbook
  lngAuditRecord = 1 ' Start row
  lngTotalRecords = 0
'
  ' Read email messages:
  Application.ScreenUpdating = False
  Set objOutlook = CreateObject("Outlook.Application")
  Set objNSpace = objOutlook.GetNamespace("MAPI")
'
  ' Allow user to choose folder:#
  Set objFolder = objNSpace.pickfolder
  ' Check if cancelled:
  If objFolder Is Nothing Then
  gblStopProcessing = True
  MsgBox "Processing cancelled"
  Exit Sub
  End If
'
  lngTotalItems = objFolder.Items.Count
  If lngTotalItems = 0 Then
  MsgBox "Outlook folder contains no email messages", vbOKOnly + vbCritical, "Error - Empty Folder"
  gblStopProcessing = True
  GoTo HandleExit
  End If
  If lngTotalItems > 0 Then
  On Error Resume Next
  Application.DisplayAlerts = False
  wb.Worksheets("Merge Data").Delete
  'wb.Worksheets("Audit").Delete
  Application.DisplayAlerts = True
  On Error GoTo HandleError
  wb.Worksheets.Add After:=Worksheets(Worksheets.Count)
  Set ws = ActiveSheet
  ws.Name = "Merge Data"

  'Insert Title Row and Format  NOTE:  THE MACRO CAN BE USED TO PARSE OUT OTHER PARTS OF AN EMAIL.
  '  I JUST COMMENTED OUT THE LINES NOT USED FOR THE CURRENT PROJECT.
  'ws.Cells(1, 1) = "Received"
  ws.Cells(1, 1) = "Email Body"
  ws.Cells(lngAuditRecord, 2) = "Subject"
  'ws.Cells(lngAuditRecord, 4) = "Attachments Count"
  'ws.Cells(lngAuditRecord, 4) = "Sender Name"
  'ws.Cells(lngAuditRecord, 5) = "Sender Email"
  ws.Range(Cells(lngAuditRecord, 1), Cells(lngAuditRecord, 1)).Select
  Selection.EntireRow.Font.Bold = True
  Selection.HorizontalAlignment = xlCenter

  'Populate the workbook
  For lngCount = 1 To lngTotalItems
  Application.StatusBar = "Reading message " & lngCount & " of " & lngTotalItems
  i = 0
  'read email info
  While i < lngTotalItems
  i = i + 1
  If i Mod 50 = 0 Then Application.StatusBar = "Reading email messages " & Format(i / lngTotalItems, "0%") & "..."
  With objFolder.Items(i)
  'Cells(i + 1, 1).Formula = .ReceivedTime
  Cells(i + 1, 1).Formula = .Body
  Cells(i + 1, 2).Formula = .Subject
  'Cells(i + 1, 4).Formula = .Attachments.Count
  'Cells(i + 1, 5).Formula = .SenderName
  'Cells(i + 1, 6).Formula = .SenderEmailAddress
  End With
  Wend
  'Set objFolder = Nothing
  ws.Activate
  Next lngCount
  lngTotalRecords = lngCount

  'Format Worksheet
  Columns("A:A").Select
  Selection.ColumnWidth = 255
  Cells.Select
  Selection.Columns.AutoFit
  Selection.Rows.AutoFit
  With Selection
  .VerticalAlignment = xlTop
  End With
  Range("A1").Select
  End If
'
' Check that records have been found:
  If lngTotalRecords = 0 Then
  MsgBox "No records were found for import", vbOKOnly + vbCritical, "Error - no records found"
  gblStopProcessing = True
  GoTo HandleExit
  End If
'
  With Selection
  Cells.Select
  .VerticalAlignment = xlTop
  .WrapText = True
  End With
  Range("A1").Select
'
HandleExit:
  On Error Resume Next
  Application.ScreenUpdating = True
  Set objNSpace = Nothing
  Set objFolder = Nothing
  Set objOutlook = Nothing
  Set ws = Nothing
  Set wb = Nothing
  If Not gblStopProcessing Then
  MsgBox "Processing completed" & vbCrLf & vbCrLf & _
  "Please check results", vbOKOnly + vbInformation, "Information"
  End If
'Call ParseBlockingSessionsEmailPartTwo
  Exit Sub
'
HandleError:
  MsgBox Err.Number & vbCrLf & Err.Description
  gblStopProcessing = True
  Resume HandleExit
End Sub