title: How to Copy the body message from outlook and paste it in Excel file?
body: <p>I am new in VBA. I am receiving 100 emails from same email address (noreply@unifonic.com) and same body message everyday (please see below photo<a href="https://i.stack.imgur.com/ex0l8.png" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/ex0l8.png" alt="enter image description here" /></a>).</p>
  <p>I tried a lot of codes but nothing is working. Can you please check my code, what am I missing. This code below, I posted it in my Outlook VBA editor but it is not working:</p>
  <pre><code>    Sub LogCheckIn()
       Dim xlApp As Excel.Application
       Dim xlWB As Excel.Workbook
       Dim xlSheet As Excel.Worksheet
       Dim olItem As Outlook.MailItem
       Dim bStarted As Boolean
       Dim strText() As String
        Dim strName As String
       Dim strStatus As String
        Dim strLocType As String
       Dim strLocName As String
       Dim strWell As String
       Dim strProject As String
       Dim i As Long, j As Long
       Const strPath As String = &quot;C:\Users\Graham Mayor\Documents\MyLog.xlsx&quot;        'the path of the workbook
  
       If Application.ActiveExplorer.Selection.Count = 0 Then
  MsgBox &quot;No Items selected!&quot;, vbCritical, &quot;Error&quot;
      Exit Sub
     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;)
  bStarted = True
    End If
  
    On Error GoTo CleanUp
   'Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strPath)
   Set xlSheet = xlWB.Sheets(&quot;Sheet1&quot;)
  For Each olItem In ActiveExplorer.Selection
  'Get the text of the message
  'and split it by paragraph
  strText = Split(olItem.Body, Chr(13))
  'Examine each paragraph
  For i = 1 To UBound(strText)
      'and locate the text relating to the item required
      If InStr(1, strText(i), &quot;Name&quot;) Then Exit For
  Next i
  strName = Right(strText(i), Len(strText(i)) - 9)
  strStatus = Right(strText(i + 1), Len(strText(i + 1)) - 16)
  strLocType = Right(strText(i + 2), Len(strText(i + 2)) - 18)
  strLocName = Right(strText(i + 3), Len(strText(i + 3)) - 18)
  strWell = Right(strText(i + 4), Len(strText(i + 4)) - 13)
  strProject = Right(strText(i + 5), Len(strText(i + 5)) - 17)
  With xlSheet
      For j = 5 To xlSheet.Range(&quot;A&quot; &amp; xlSheet.Rows.Count).End(xlUp).Row
          If Trim(LCase(xlSheet.Cells(j, 1))) = Trim(LCase(strName)) Then
              xlSheet.Cells(j, 2) = strStatus
              xlSheet.Cells(j, 3) = strLocType
              xlSheet.Cells(j, 4) = strLocName
              xlSheet.Cells(j, 5) = strWell
              xlSheet.Cells(j, 6) = strProject
          End If
      Next j
     End With
      Next olItem
    CleanUp:
      xlWB.Close SaveChanges:=True
      If bStarted Then
      xlApp.Quit
      End If
          Set xlApp = Nothing
          Set xlWB = Nothing
          Set xlSheet = Nothing
          Set olItem = Nothing
       End Sub
  </code></pre>