Извлечение конкретных данных из emailbody

---

как мы можем экспортировать определенные данные из тела сообщения outlook в excel .
на 2 модели почты
и как мы можем посчитать количество строк на теле почты.
а приведу вам мой пример .
почта тип1 один

[First Name],Boby Rayan
[Cont Number], A0ED011011782
[Send Date],03/03/18
[Total Mt],00742241
[Total Mtc],00209166
[Total Mtb],00533075
[Total Mtfs],00101361

почта type2 один из них

[First Name],David porter
[Cont Number], A1UF011011598
[Send Date],03/01/18
[Total Mtb],00258552
[Total Mtfs],00146186

и я получаю почту типа и 2 в том же почтовом ящике
то, что мне нужно в excel, выглядит следующим образом

First Name * Cont Number   * Send Date* Total Mt * Total Mtc * Total Mtb * Total Mtfs
Boby Rayan * A0ED011011782 * 03/03/18 * 00742241 * 00209166  *00533075   * 00101361
David porter*A1UF011011598 * 03/01/18  *         *           * 00258552  * 00101361

Что я уже пробовал:

я попробовал это сделать, если кто-то может мне помочь

Sub Extract()
 On Error Resume Next
 Set myOlApp = Outlook.Application
 Set mynamespace = myOlApp.GetNamespace("mapi")
 Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
 
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim x As Long
Dim arrHeaders As Variant



Set xlobj = CreateObject("excel.application.15")
 xlobj.Visible = True
 xlobj.Workbooks.Add
 xlobj.Worksheets("Sheet1").Name = "Statusmail"
 
'Set the header
 xlobj.Range("a" & 1).Value = "Sender"
 xlobj.Range("a" & 1).Font.Bold = "True"
 'xlobj.Range("b" & 1).Value = "Date"
 'xlobj.Range("b" & 1).Font.Bold = "True"
 xlobj.Range("c" & 1).Value = "First Name"
 xlobj.Range("c" & 1).Font.Bold = True
 xlobj.Range("d" & 1).Value = "Cont Number"
 xlobj.Range("d" & 1).Font.Bold = True
 xlobj.Range("e" & 1).Value = "Send Date"
 xlobj.Range("e" & 1).Font.Bold = True
 xlobj.Range("f" & 1).Value = "Total Mt"
 xlobj.Range("f" & 1).Font.Bold = True
 xlobj.Range("g" & 1).Value = "Total Mtc"
 xlobj.Range("g" & 1).Font.Bold = True
 xlobj.Range("h" & 1).Value = "Total Mtb"
 xlobj.Range("h" & 1).Font.Bold = True
 xlobj.Range("i" & 1).Value = "Total Mtfs"
 xlobj.Range("i" & 1).Font.Bold = True
For x = 1 To myfolder.Items.Count
  Set myitem = myfolder.Items(x)
  msgtext = myitem.Body
  'search for specific text
    delimtedMessage = Replace(msgtext, "[First Name],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Cont Number],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Send Date],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Total Mt],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Total Mtc],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Total Mtb],", "###")
    delimtedMessage = Replace(delimtedMessage, "[Total Mtfs],", "###")
    messageArray = Split(delimtedMessage, "###")
   'write to excel
    xlobj.Range("a" & x + 1).Value = myitem.To
    xlobj.Range("b" & x + 1).Value = messageArray(0)
    xlobj.Range("c" & x + 1).Value = messageArray(1)
    xlobj.Range("d" & x + 1).Value = messageArray(2)
    xlobj.Range("e" & x + 1).Value = messageArray(3)
    xlobj.Range("f" & x + 1).Value = messageArray(4)
    xlobj.Range("g" & x + 1).Value = messageArray(5)
    xlobj.Range("h" & x + 1).Value = messageArray(6)
    xlobj.Range("i" & x + 1).Value = messageArray(7) 


 Next
 End
 End Sub

---