Is there a way to parse just the body of an Outlook Email into specific cells in Excel?

Question

I'm trying to automate a workflow, where necessary information gets sent to my email while I'm responding to an alarm call, then excel takes the body of that email and parses it into individual cells.

After two weeks of researching, I've found the beginnings, but I'm hoping for something more concise.

This is my code so far:

Sub OutlookExtract()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Alarms")

i = 1

For Each OutlookMail In Folder.Items
    If OutlookMail.ReceivedTime >= Range("From_date").Value Then
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body
        
        i = i + 1
    End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

My issue is, that while it does technically include the email body, I have to follow it up with more Excel syntax in order to further parse the info into something useful.

I have to code multiple cells with MID LEN in order to pull my times out, and then run an entirely different code to paste those values in where I actually need them to go:

Sub ValuePaste()

    Range("B3").Value = Range("N3")
    Range("B4").Value = Range("N4")
    Range("B5").Value = Range("N5")
    Range("B6").Value = Range("N6")
    Range("B7").Value = Range("N7")
    Range("B10").Value = Range("N8")
    Range("G29").Value = Range("N9")
    Range("B11").Value = Range("N10")
    Range("O11").Value = Range("N11")
    Range("B13").Value = Range("N12")
    Range("B14").Value = Range("N13")
    Range("B16").Value = Range("N14")

End Sub

---

This is the table I have on my Inputs sheet (A), Sub ValuePaste() uses the table on the right to paste the values from sheet (B) into my inputs

Honestly, I'm fine running the two codes, and I know that if I figured out how to properly parse the body then I'd be able to combine them, but as it is now, I have to run the first code, check that none of my MID LEN's have errored/have the correct data, and then run the second code.

I'm trying to automate this in order to cut down on human error, but it feels like it's just adding more opportunity for me to mess something up.

---

Mail Discussion Body

---

Cells I Want To Populate

---

Current Workaround Table

---

Workaround Table Showing Formulas

Answer 1

Please, try the next function. It will return a 2D array having in the first row the necessary headers and in the second the extracted corespondent values:

Function ExtractBodyData(strBody As String) As Variant
    Dim arrBody, arrHeaders, mtch
    Dim arr, i As Long, arrFin, arrLine
    
    arrBody = Split("Date,A,D,O,C,I,B,Resp,Type,Class,BLDG,Floor", ",")
    arrHeaders = Split("Date,Alarm,Dispatch,On Scene,Clear,Incident #,Dispatcher,Response,Type,Class,BLDG,Floor", ",")
    
    arr = Split(strBody, vbCrLf)
    ReDim arrFin(1 To UBound(arr) + 1, 1 To 2)
    For i = 0 To UBound(arr)
        arrLine = Split(arr(i), ":")
        If UBound(arrLine) = 1 Then
            mtch = Application.match(arrLine(0), arrBody, 0)
            If Not IsError(mtch) Then
                arrFin(i + 1, 1) = arrHeaders(mtch - 1)
                arrFin(i + 1, 2) = VBA.Trim(arrLine(1))
            End If
        End If
    Next i
    ExtractBodyData = Application.Transpose(arrFin)
End Function

It must be used in the next way:

Sub TestExtractBodyData()
 Dim lastR, arr
 arr = ExtractBodyData(OutlookMail.Body) 'this can be inserted in your existing code
 If Range("E4").value <> "Date" Then 'if not the header exists (in the fourth row, starting from "E4"):
    'drop the extracted array, headers included:
    Range("E4").Resize(UBound(arr), UBound(arr, 2)).Value2 = arr 
 Else 'If the headers exists:
    'Make a slice for only the second row of the array:
    arr = Application.Index(arr, 2, 0) 'make an array of the array second row
    lastR = Range("E" & rows.count).End(xlUp).Row + 1 'determine the last empty row
    Range("E" & lastR).Resize(1, UBound(arr)).Value2 = arr 'drop the slice in the appropriate row
 End If
End Sub

Answer 2

So here is a little example. ExtractInfoAndWriteToSheet takes the text and splits it into lines. Here you need to check whether you need vbnewline or another character like Chr(10) or Chr(13) (vbNewLine = Chr(13) + Chr(10)).

Sub ExtractInfoAndWriteToSheet(emailBody As String)
    
    Dim splitted() As String
    Dim curLine As String
    Dim i As Long
    
    splitted = Split(emailBody, vbNewLine)
    
    For i = LBound(splitted) To UBound(splitted)
        curLine = splitted(i)
        CheckLineAndWriteToSheet curLine
    Next
    
End Sub

Each line is then Processes in CheckLineAndWriteToSheet. Left(line,2) extracts the first two characters. This approach is just a sample and not fail safe at all. But I think from here you can elaborate what you need.

Sub CheckLineAndWriteToSheet(line As String)
    
    
    Select Case Left(line, 2)
        Case "A:"
            ActiveSheet.Range("A1").Value = Right(line, Len(line) - 2)
        Case "B:"
            ActiveSheet.Range("B1").Value = Right(line, Len(line) - 2)
    End Select
        
End Sub

Also you shoudn't use ActiveSheet but define the Sheet somewhere and use it instead of ActiveSheet.