Extract a name from the body of an email

[DEllis]

Hi everyone, I have the following code which extracts data into an excel spreadsheet. The issue is, the " Cells(iRows, 2) = item.SenderName" only will pull in the name when the user uses their name in their emails, which some folks do not. However, in the body of the email that we want to extract is "Name: (person's name) I can bring in the entire body of the email which is in the code below as row 6, however, I would really like to only pull in the person's name and not all content in the body of the email. Any help?

Sub eaddrtosuppr()
    On Error GoTo ErrHandler
    Dim objOutlook As Object
    Set objOutlook = CreateObject("Outlook.Application")
   
    Dim objNSpace As Object
    Set objNSpace = objOutlook.GetNamespace("MAPI")

   
    Dim oAccount As Account
    Dim item As Object
    Dim procfolder As Folder
    Dim iRows, iCols As Integer
    Dim rng As Range
    Dim lastrow As Long
   
    Set rng = ActiveSheet.UsedRange
    lastrow = rng.Rows(ActiveSheet.UsedRange.Rows.Count).Row
   
    'lastrow = ActiveSheet.ListObjects("Unsubs").Range.Rows.Count
    iRows = lastrow + 1

    Set procfolder = objNSpace.Folders("My Folder").Folders("Inbox").Folders("List")
       For Each item In procfolder.Items
             Cells(iRows, 1) = item.SenderEmailAddress
            Cells(iRows, 2) = item.SenderName
            Cells(iRows, 3) = item.ReceivedTime
            Cells(iRows, 4) = "No marketing"
            Cells(iRows, 5) = "No targeting"
            Cells(iRows, 6) = item.Body
            iRows = iRows + 1
        Next
   
    rng.RemoveDuplicates Columns:=1, Header:=xlYes
    rng.Sort Key1:=Columns("C"), Order1:=xlDescending, Header:=xlYes
   
    Set rng = Nothing
    Set procfolder = Nothing
    Set objOutlook = Nothing
    Set objNSpace = Nothing

ErrHandler:
    Debug.Print Err.Description
End Sub

 

[Siddharth Rout]

Try this. Pass the email body to the below function

'~~> Pass the email body to this function
Private Function GetName(EmailBody As String) As String
    Dim Ar As Variant
    Dim i As Long
    Dim Nm As String
   
    '~~> Split the body text into an array
    '~~> If vbNewLine doesn't work then try vbCrLf or vbLf
    Ar = Split(EmailBody, vbNewLine)
   
    '~~> Loop through the array and find the line which has "Name:"
    For i = LBound(Ar) To UBound(Ar)
        If InStr(1, Ar(i), "Name:", vbTextCompare) Then
            '~~> Extract name
            Nm = Split(Ar(i), ":")(1)
            Exit For
        End If
    Next i
   
    GetName = Nm
End Function

Here is how you use the above function

 

[DEllis]

Try this. Pass the email body to the below function

'~~> Pass the email body to this function
Private Function GetName(EmailBody As String) As String
    Dim Ar As Variant
    Dim i As Long
    Dim Nm As String
  
    '~~> Split the body text into an array
    '~~> If vbNewLine doesn't work then try vbCrLf or vbLf
    Ar = Split(EmailBody, vbNewLine)
  
    '~~> Loop through the array and find the line which has "Name:"
    For i = LBound(Ar) To UBound(Ar)
        If InStr(1, Ar(i), "Name:", vbTextCompare) Then
            '~~> Extract name
            Nm = Split(Ar(i), ":")(1)
            Exit For
        End If
    Next i
  
    GetName = Nm
End Function

Here is how you use the above function

View attachment 60405

Thank you this worked perfectly!

 

[Siddharth Rout]

Thank you this worked perfectly!

Thanks for the feedback

 

[Peter_SSs]

When posting vba code in the forum, please use the available code tags.
My signature block below has more details. I have added them for you this time.

Thank you this worked perfectly!

In that case I think this single line-swap in your original code should also work for you?

Cells(iRows, 2) = item.SenderName
Cells(iRows, 2) = Split(Filter(Split(item.Body, vbNewLine), "Name:")(0), ":")(1)