How to Copy the body message from outlook and paste it in Excel file?

Question

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).

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:

    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 = "C:\Users\Graham Mayor\Documents\MyLog.xlsx"        'the path of the workbook

     If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
   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")
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("Sheet1")
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), "Name") 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("A" & 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

Answer 1

I believe the main issues with your code were:

1. Using the Right function to extract the contents for each element in the strText array. I suggest you use the Mid function instead (see below code), because you only have to specify the starting point within the string, and it returns from that point onwards and you don't have to worry about the string length.

2. When you create the strText array using the Split method, it was creating empty paragraphs and spreading the text you want in lines other than the ones you were referencing with the array index. So I suggest you use the Locals window from VBA Editor (View > Locals Window) to see exactly where are the paragraphs you want (see below picture).

   

   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 = "C:\Users\Graham Mayor\Documents\MyLog.xlsx"        'the path of the workbook
   
       If Application.ActiveExplorer.Selection.Count = 0 Then
           MsgBox "No Items selected!", vbCritical, "Error"
           Exit Sub
       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")
           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("Sheet1")
   
       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 = 5 To UBound(strText)
               'and locate the text relating to the item required
               '(I changed the If statement here to avoid)
               If InStr(1, strText(i), "Name") <> 0 Then
                   strName = Mid(strText(i), 8)
                   strStatus = Mid(strText(i + 4), 18) 'REPLACE ACCORDING TO THE LOCALS WINDOW
                   strLocType = Mid(strText(i + 8), 10) 'REPLACE ACCORDING TO THE LOCALS WINDOW
                   strLocName = Mid(strText(i + 8), 10) 'REPLACE ACCORDING TO THE LOCALS WINDOW
                   strWell = Mid(strText(i + 8), 10) 'REPLACE ACCORDING TO THE LOCALS WINDOW
                   strProject = Mid(strText(i + 8), 10) 
   
                   With xlSheet
                       For j = 5 To xlSheet.Range("A" & 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
   
                   Exit For
               End If
           Next i
       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