How to export message body and data from Table to Excel from outlook 2010

Question

I usually get Employee announcement in emails and I need to compile excel sheet from all these emails to know change in status of employee from previous line to current line .
Dear Concerned,
The change in status of the following employee has been carried out as per following details:
New Status
Change in Job
Effective Date
01-Feb-2015
Employee Name
Ricky ponting
Employee Code
4982
Designation
Sourcing Executive (Secondment)
Job Group
1A
Department
Sourcing & Supply Chain
Unit
Technology Sourcing
Division
Finance
Location
sydney
Reporting Line
Mr Micheal king
Note: Ricky Ponting  was previously working as
Tariff Implementation Support Officer XYZ organization was reporting to
Mr Robin Sing
I need working code that export about HTML table data as well last Note : full line so that I can have an excel file of 2000 Employees whoes status have been changed and I can easily sort out from which previous line they were reporting to new line and I
can get in touch with the new line for any Access rights re-authorization exercise on later stage .
Currently i am using following code thats working fine with the table extraction but NOTE: line is not being fetched with the following code based on following URL
https://techniclee.wordpress.com/2011/10/29/exporting-outlook-messages-to-excel/
Const MACRO_NAME = "Export Messages to Excel (Rev Sajjad)"
Private Sub ExportMessagesToExcel()
    Dim olkFld As Outlook.MAPIFolder, _
        olkMsg As Outlook.MailItem, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        arrCel As Variant, _
        varCel As Variant, _
        lngRow As Long, _
        intPtr As Integer, _
        intVer As Integer
    Set olkFld = Session.PickFolder
    If TypeName(olkFld) = "Nothing" Then
        MsgBox "You did not select a folder.  Operation cancelled.", vbCritical + vbOKOnly, MACRO_NAME
    Else
        intVer = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        Set excWks = excWkb.Worksheets(1)
        excApp.Visible = True
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Received"
            .Cells(1, 3) = "Sender"
            .Cells(1, 4) = "New Status"
            .Cells(1, 5) = "Effective Date"
            .Cells(1, 6) = "Employee Name"
            .Cells(1, 7) = "Employee Code"
            .Cells(1, 8) = "Designation"
            .Cells(1, 9) = "Job Group"
            .Cells(1, 10) = "Department"
            .Cells(1, 11) = "Unit"
            .Cells(1, 12) = "Division"
            .Cells(1, 13) = "Location"
            .Cells(1, 14) = "Reporting Line"
            .Cells(1, 15) = "Note:"
        End With
        lngRow = 2
        For Each olkMsg In olkFld.Items
            excWks.Cells(lngRow, 1) = olkMsg.Subject
            excWks.Cells(lngRow, 2) = olkMsg.ReceivedTime
            excWks.Cells(lngRow, 3) = GetSMTPAddress(olkMsg, intVer)
           For intPtr = LBound(arrCel) To UBound(arrCel)
                Select Case Trim(arrCel(intPtr))
                    Case "New Status"
                        excWks.Cells(lngRow, 4) = arrCel(intPtr + 1)
                    Case "Effective Date"
                        excWks.Cells(lngRow, 5) = arrCel(intPtr + 1)
                    Case "Employee Name"
                        excWks.Cells(lngRow, 6) = arrCel(intPtr + 1)
                    Case "Employee Code"
                        excWks.Cells(lngRow, 7) = arrCel(intPtr + 1)
                    Case "Designation"
                        excWks.Cells(lngRow, 8) = arrCel(intPtr + 1)
                    Case "Job Group"
                        excWks.Cells(lngRow, 9) = arrCel(intPtr + 1)
                    Case "Department"
                        excWks.Cells(lngRow, 10) = arrCel(intPtr + 1)
                    Case "Unit"
                        excWks.Cells(lngRow, 11) = arrCel(intPtr + 1)
                    Case "Division"
                        excWks.Cells(lngRow, 12) = arrCel(intPtr + 1)
                    Case "Location"
                        excWks.Cells(lngRow, 13) = arrCel(intPtr + 1)
                    Case "Reporting Line"
                        excWks.Cells(lngRow, 14) = arrCel(intPtr + 1)
                    Case "Note:"
                        excWks.Cells(lngRow, 14) = arrCel(intPtr + 1)
                    End Select
            Next
            lngRow = lngRow + 1
        Next
        excWks.Columns("A:W").AutoFit
        excApp.Visible = True
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
    End If
    Set olkFld = Nothing
End Sub
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function
Sub DebugLabels()
    Dim olkMsg As Outlook.MailItem, objFSO As Object, objFil As Object, strBuf As String, strPth As String, arrCel As Variant, intPtr As Integer
    strPth = Environ("USERPROFILE") & "\Documents\Debugging.txt"
    Set olkMsg = Application.ActiveExplorer.Selection(1)
    arrCel = Split(GetCells(olkMsg.HTMLBody), Chr(255))
    For intPtr = LBound(arrCel) To UBound(arrCel)
        strBuf = strBuf & StrZero(intPtr, 2) & vbTab & "*" & arrCel(intPtr) & "*" & vbCrLf
    Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFil = objFSO.CreateTextFile(strPth)
    objFil.Write strBuf
    objFil.Close
    Set olkMsg = Application.CreateItem(olMailItem)
    With olkMsg
        .Recipients.Add "[email protected]"
        .Subject = "Debugging Info"
        .BodyFormat = olFormatPlain
        .Body = "The debugging info for the selected message is attached.  Please click Send to send this message to David."
        .Attachments.Add strPth
        .Display
    End With
    Set olkMsg = Nothing
    Set objFSO = Nothing
    Set objFil = Nothing
End Sub
Function StrZero(varNumber, intLength)
    Dim intItemLength
    If IsNumeric(varNumber) Then
        intItemLength = Len(CStr(Int(varNumber)))
        If intItemLength < intLength Then
            StrZero = String(intLength - intItemLength, "0") & varNumber
        Else
            StrZero = varNumber
        End If
    Else
        StrZero = varNumber
    End If
End Function

Answer 1

Dear Graham
I am already big fan of yours and using mail to many Addin from years from word 2007 to Word 2010 :) and still loving it and I use it for access re-authorization from Lines for application accesses . I tried and finally got understanding of the Extract to
mail Addin and after tweaking excel - Text To columns and other few things finally i was able to get the required data - from morning to now :) I am happy to see your provided guidance
Thanks alot - by the way why your Mail to many add-in is so slow now these days :) previous versions usually help me send 1000 emails in 10 minutes now it takes long time :)