Extracting text data from e-mail bodies can be complicated but assuming the example is a true reflection of the message layout, then the following will extract the data you requested to the named worksheet, when you send the message. Start with a workbook with just the header row as shown in your illustration. It might be better if you created such messages from a template to ensure consistency.
sheet.jpg
Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 02 Jul 2020
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim wdDoc As Object
Dim oRng As Object
Dim oPara As Object, oFind As Object
Dim lngPara As Long, i As Integer
Dim sIndex As String, sEndClient As String, sRaisedBy As String
Dim olInsp As Inspector
Dim sSender As String, sRecipient As String, sDate As String
Dim sValues As String
Dim vIndex As Variant
Const strWB As String = "E:\Email\Email Statistics.xlsx" 'Must exist
Const strSheet As String = "Sheet1"
With Item
If TypeName(Item) = "MailItem" And .Subject = "Index Coverage Request" Then
sDate = Format(Date, "d-MMM-yy")
sSender = .SenderEmailAddress
sRecipient = .Recipients.Item(1).Address
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
For lngPara = 3 To oRng.Paragraphs.Count
Set oPara = oRng.Paragraphs(lngPara).Range
oPara.End = oPara.End - 1
If oPara.Words.Count = 1 And Len(oPara) > 1 Then
If sIndex = "" Then
sIndex = oPara.Text
Else
sIndex = sIndex & "|" & oPara.Text
End If
Else
Set oFind = oPara.Duplicate
With oFind
.Start = .Start + InStr(1, oFind, "out for") + 7
.End = .Start + InStrRev(oFind, "behalf") - 5
End With
sRaisedBy = Trim(oFind.Text)
'MsgBox sRaisedBy
Set oFind = oPara.Duplicate
With oFind
.Start = .Start + InStr(1, oFind, "behalf of") + 9
oFind.MoveEndWhile ".", -1073741823
sEndClient = oFind.Text
' MsgBox sEndClient
End With
Exit For
End If
Next lngPara
End If
vIndex = Split(sIndex, "|")
For i = 0 To UBound(vIndex)
WriteToWorksheet strWB, strSheet, sRecipient, sSender, CStr(vIndex(i)), sEndClient, sRaisedBy, sDate
Next i
End With
lbl_Exit:
Set wdDoc = Nothing
Set oRng = Nothing
Set oFind = Nothing
Set olInsp = Nothing
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strRecipient As String, _
strSender As String, _
strIndex As String, _
strClient As String, _
strRaisedBy As String, _
strDate As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
strRange = strRange & "$]"
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [Sheet1$] VALUES('" & _
strRecipient & "', '" & _
strSender & "', '" & _
strIndex & "','" & _
strClient & "', '" & _
strRaisedBy & "', '" & _
strDate & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function