txt = myitem.Body
    a = Split(txt, vbNewLine)

    If myitem.SenderName = "Нужный отправитель" Then

Set b = a.workbooks.Open(xlsFileName)

 Option Explicit
Dim wb As Object
Dim Wsh As Object
Dim App As Object
Dim blnEnd As Boolean
Dim rng As Object
Dim arr As Object
Dim filteredItems As items

Sub OpenBook(path As String, fileName As String)
    Dim fname As String

    Set App = CreateObject("Excel.Application")
    Dim fullPath As String: fullPath = path & App.PathSeparator & fileName
    If Dir(fullPath) <> "" Then
        Set wb = App.Workbooks.Open(fullPath)
        App.Visible = True
        wb.Activate
    Else:
        Select Case MsgBox("Создать новую книгу?", vbYesNo)
        Case vbYes: Set wb = App.Workbooks.Add
        Case vbNo: blnEnd = True
        End Select
        If Not blnEnd Then
            Do
                fname = App.GetSaveAsFilename & ".xls"
            Loop Until fname <> ""
            wb.SaveAs fileName:=fname
            App.Visible = True
            wb.Activate
        End If
    End If
End Sub
Sub ManageWB(ParamArray ColNames())
    Set Wsh = wb.Worksheets(1)
    Set rng = Range("A1").CurrentRegion
    If rng.Cells.Count = 1 Then
        rng.Resize(1, UBound(ColNames) + 1).Value = ColNames
    End If
    Set rng = rng(1, 1)

    Dim name
    Dim i&
    Dim lastRow&: lastRow = rng.CurrentRegion.Rows.Count

    Call getCollectionOfMails("Ваше_условие")
    Dim mi As MailItem
    Dim vals
    vals = Split("сервер - клиент:клиент - сервер:тестовый объем", ":") 
    On Error Resume Next

    For Each mi In filteredItems

        Set arr = ExtractFromMail(mi, vals)
        Select Case lastRow

        Case Is < 2
            For Each name In ColNames
                i = i + 1
                rng.Find(name).Offset(1, 0).Value = arr(name)
                If Err.Number <> 0 Then
                    MsgBox "There is an error in function"
                    Exit Sub
                End If
            Next name

        Case Is >= 2
            For Each name In ColNames
                If arr.Exists(name) Then
                    rng.Parent.Cells(lastRow + 1, rng.Find(name).Column) = arr(name)
                End If
            Next name

        End Select  

       Next mi
        On Error GoTo 0
        wb.Close SaveChanges:=True
        App.Quit
End Sub
Function ExtractFromMail(mi As MailItem, dicKeys, Optional sep = vbNewLine)
    Dim key, val
    Dim StartPos&, EndPos&

    Dim txtBody: txtBody = mi.Body
    Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")

    On Error Resume Next

    For Each key In dicKeys
        val = Split(txtBody, key)(1)
        val = Split(val, sep)(0)
        val = Replace(val, ": ", "")
        Dic.Add key, val
    Next key
    Dic.Add "Пользователь", mi.SenderName
    Dic.Add "Дата/время", mi.ReceivedTime

    On Error GoTo 0

    Set ExtractFromMail = Dic
End Function
Sub getCollectionOfMails(condition As String, Optional blnUnRead As Boolean = False)
    Dim fld As Folder: Set fld = Session.Folders(2).Folders("Входящие") ' это мой адрес входящей папки - придется изменить
    Dim i As items: Set i = fld.items

    Dim fullCondition As String

    fullCondition = "[От] = '" & condition & "'"
    Set filteredItems = i.Restrict(fullCondition)
End Sub
Sub setNothing()
    Set wb = Nothing
    Set Wsh = Nothing
    Set App = Nothing
    Set rng = Nothing
    Set arr = Nothing
    Set filteredItems = Nothing
End Sub
Sub main()
    Dim p As String: p = "C:\Ex"    'path
    Dim fn As String: fn = "Трассировка.xlsx"
    Call OpenBook(p, fn)
    If blnEnd Then
        MsgBox "Something wasn't right", vbCritical, "Oooops!"
        Exit Sub
    End If
    Call ManageWB("Пользователь", "сервер - клиент", "клиент - сервер", _
                  "тестовый объем", "Дата/время")
    Call setNothing
End Sub
 

'---------------------------------------------------------------------------------------
' Module      : Final
' Author      : Fjedor/Vse_Pro100 @ PlanetaExcel.ru
' Date        : 23.01.2015
' Purpose     : moves parsed data into excel workbook.
' Miscelaneous: Please, make sure the code is properly attributed when used.
'---------------------------------------------------------------------------------------

Option Explicit
Const keys As String = _
   "сервер - клиент:клиент - сервер:тестовый объем" ':Пользователь:Дата/время"
Const separator As String = vbNewLine
Const wbkAddress = "C:\book\"
Const fileName = "Test.xlsx"
Const userPattern = "\.*пользователем\s(\.*)\s*в\s*(\d+.\d+.\d+\s\d+:\d+:\d+).*"

Enum ColNames
U = 1 'user
SC = 2 'server-client
CS = 3 'client-server
TV = 4 'test volume
dt = 5 'date/time
End Enum


Function ExtractFromMail(mi As MailItem, Optional sep = vbNewLine)

Dim key, val
Dim StartPos&, EndPos&
Dim txtBody: txtBody = mi.Body
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim user$, dt$

With CreateObject("vbscript.regexp")
.Pattern = userPattern
With .Execute(txtBody)(0)
user = .SubMatches(0)
dt = .SubMatches(1)
End With
End With

On Error Resume Next

For Each key In Split(keys, ":")
val = Split(txtBody, key)(1)
val = Split(val, separator)(0)
val = Replace(val, ": ", "")
dic.Add key, val
Next key

dic.Add "Пользователь", user
dic.Add "Дата/время", dt

On Error GoTo 0

Set ExtractFromMail = dic
End Function
Sub main()

Dim xl As Object: Set xl = CreateObject("Excel.Application") ': xl.Visible = False ': Set xl = New Excel.Application:
Dim wbk As Object: Set wbk = xl.Workbooks.Open(wbkAddress & fileName)
Dim rng As Object: Set rng = wbk.Worksheets(1).[a2].CurrentRegion
Dim lastRow&: lastRow = rng.Rows.Count
Dim mi As MailItem
Dim i&

On Error Resume Next

Set mi = ActiveInspector.CurrentItem
Dim dic As Object: Set dic = ExtractFromMail(mi)

With rng.Parent
.Cells(lastRow + 1, ColNames.U) = dic("Пользователь")
.Cells(lastRow + 1, ColNames.SC) = dic("сервер - клиент")
.Cells(lastRow + 1, ColNames.CS) = dic("клиент - сервер")
.Cells(lastRow + 1, ColNames.TV) = dic("тестовый объем")
.Cells(lastRow + 1, ColNames.dt) = dic("Дата/время")
End With

On Error GoTo 0
If Err.Number <> 0 Or dic Is Nothing Then
Dim str As String
str = "Инспектор для сообщения не вызван либо сообщение не валидно"
MsgBox str, vbCritical, "Ошибка"
wbk.Close SaveChanges:=False
GoTo Handler
End If

wbk.Close SaveChanges:=True
MsgBox "Записи успешно занесены", vbInformation

Handler:
xl.Quit
Set xl = Nothing: Set wbk = Nothing: Set dic = Nothing
End Sub