title: How to copy specific text from the body of the email?
body: <pre><code>Option Explicit
  
  Sub GetFromInbox()
  
  Dim olApp As Outlook.Application
  Dim olNs As Outlook.Namespace
  Dim olFldr As Outlook.MAPIFolder
  Dim olItms As Outlook.Items
  Dim olMail As Variant
  Dim i As Long
  
  Set olApp = New Outlook.Application
  Set olNs = olApp.GetNamespace("MAPI")
  Set olFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("impMail")
  Set olItms = olFldr.Items
  
  olItms.Sort "Subject"
  
  For Each olMail In olItms
      If InStr(olMail.Subject, "SubjectoftheEmail") &gt; 0 Then
          ThisWorkbook.Sheets("Fixings").Cells(2, 2).Value = olMail.Body
  
      End If
  Next olMail
  
  Set olFldr = Nothing
  Set olNs = Nothing
  Set olApp = Nothing
  End Sub
  </code></pre>
  
  <p>This code help me to download whole body of the email but I need specific bold text in cells. The email body is always as follows. The lines are always in the same order. All lines are always present. The all names in email could be known in advance.</p>
  
  <blockquote>
    <p>This EMAIL IS ONLY FOR Internal use</p>
    
    <p>Hi</p>
    
    <p>@ABC4: please add the following detail in system (for <strong>12-Jan-2019</strong>):</p>
    
    <p><strong>12345_ABC_MakOpt --- 264532154.78<br>
    12345_ABC_GAPFee --- 145626547.80</strong> </p>
    
    <p>thanks</p>
  </blockquote>
  
  <p>´ -----------------------------------------------------
          'get setup
          '-----------------------------------------------------</p>
  
  <pre><code>    Dim wb As Workbook
      Dim rngEmailSubject As Range
      Dim rngInstrumentName As Range
      Dim rngDate As Range
      Dim rngAmount As Range
      Dim arrFixing() As typFixing
      Dim rngValue As Range
  
      Dim rowIdx As Integer
      Dim ix As Integer
      Dim fixingDate As Date
  
      With wb.Sheets("FixingFromEmail")
  
          Set rngInstrumentName = .Range("instrument.name")
          Set rngDate = .Range("Date")
          Set rngAmount = .Range("Amount")
  
          rowIdx = rngInstrumentName.Row
          ix = 0
  
          Do While True
  
              rowIdx = rowIdx + 1
               If Not IsEmpty(.Cells(rowIdx, rngInstrumentName.Column).Value) _
          Then
  
                  ix = ix + 1
  
                  ReDim Preserve arrFixing(1 To ix)
                  arrFixing(ix).InstrumentName = .Cells(rowIdx, rngInstrumentName.Column).Value
                  arrFixing(ix).Date = .Cells(rowIdx, rngDate.Column).Value
                  arrFixing(ix).Amount = .Cells(rowIdx, rngAmount.Column).Value
  
  
              Else
                  Exit Do
              End If
  
          Loop
  
      End With´
  </code></pre>