Parsing & Segregating Outlook Mail Fields to Excel

R

raghuram.star

Board Regular
Joined
Sep 5, 2012
Messages
102
I want to run a macro with will parse the Outlook Mail Fields to Excel

I get the Fields of Outlook mail through the following code

Code: 
Sub ExportMessagesToExcel()

    Dim olkMsg As Object
    Dim excApp As Object
    Dim excWkb As Object
    Dim excWks As Object
    Dim intRow As Integer
    Dim intVersion As Integer
    Dim strFilename As String


    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
    If strFilename <> "" Then
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        
        'Write Excel Column Headers
        With excWks
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "Received Date"
            .Cells(1, 4) = "Sender"
            .Cells(1, 5) = "Body"
        End With
        intRow = 2
        'Write messages to spreadsheet
        For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
            'Only export messages, not receipts or appointment requests, etc.
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 2) = olkMsg.Subject
                excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 4) = GetSMTPAddress(olkMsg, intVersion)
                excWks.Cells(intRow, 5) = olkMsg.Body
                intRow = intRow + 1
            End If
        Next
            Set olkMsg = Nothing
            excWkb.SaveAs strFilename
            excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
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

It generates an Excel Sheet in this format

Code: 
[TABLE="width: 861"]
<tbody>[TR]
[TD][B]Subject[/B][/TD]
[TD][B]Received Date[/B][/TD]
[TD][B]Sender[/B][/TD]
[TD][B]Body (Edited)[/B][/TD]
[/TR]
[TR]
[TD]RE: DGR151 Change Request #1 *04-Oct*[/TD]
[TD="align: right"]10/5/2012 5:46[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]RE: DGR151 Change Request #2 *04-Oct*[/TD]
[TD="align: right"]10/5/2012 5:38[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]RE: ddg SCR splits[/TD]
[TD="align: right"]10/5/2012 5:32[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]element missing in the SCR[/TD]
[TD="align: right"]10/5/2012 3:19[/TD]
[TD]Aruna.Ria@company.com[/TD]
[TD]Request - Element Missing[/TD]
[/TR]
[TR]
[TD]Please insert elemnt to LCT[/TD]
[TD="align: right"]10/5/2012 2:55[/TD]
[TD]Jitendar.Kuma@company.com[/TD]
[TD]Request - Insert Element[/TD]
[/TR]
[TR]
[TD]RE: DGR151 Change Request #1 *04-Oct*[/TD]
[TD="align: right"]10/5/2012 2:39[/TD]
[TD]Deb.Rob@company.com[/TD]
[TD]Approved[/TD]
[/TR]
[TR]
[TD]RE: DGR151 Change Request #2 *04-Oct*[/TD]
[TD="align: right"]10/5/2012 2:15[/TD]
[TD]Deb.Rob@company.com[/TD]
[TD]Approved[/TD]
[/TR]
[TR]
[TD]FW: ddg SCR splits[/TD]
[TD="align: right"]10/5/2012 2:11[/TD]
[TD]Deb.Rob@company.com[/TD]
[TD]Approved[/TD]
[/TR]
[TR]
[TD]RE: Access[/TD]
[TD="align: right"]10/5/2012 1:18[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]RE: Access[/TD]
[TD="align: right"]10/5/2012 1:13[/TD]
[TD]Karan.Gini@company.com[/TD]
[TD]Request - Access[/TD]
[/TR]
[TR]
[TD]Please grant CONTROL privileges for -8[/TD]
[TD="align: right"]10/5/2012 1:01[/TD]
[TD]Tarnga.Voe@company.com[/TD]
[TD]Request - Controll Privileges[/TD]
[/TR]
[TR]
[TD]FW: NDGR1[/TD]
[TD="align: right"]10/5/2012 0:07[/TD]
[TD]Jean.Le@company.com[/TD]
[TD]Request - NDGR1 Access[/TD]
[/TR]
[TR]
[TD]RE: Requesting -9 Core SCR to be copied to PF[/TD]
[TD="align: right"]10/4/2012 21:14[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]RE: VBA_TPP_SP_DELAY.DOC - Element deletion needed[/TD]
[TD="align: right"]10/4/2012 21:09[/TD]
[TD]Karan.Gini@company.com[/TD]
[TD]Request - Rejected[/TD]
[/TR]
[TR]
[TD]RE: VBA_TPP_SP_DELAY.DOC - Element deletion needed[/TD]
[TD="align: right"]10/4/2012 21:05[/TD]
[TD]Christ.Rev@company.com[/TD]
[TD]Approved - Element Deletion[/TD]
[/TR]
[TR]
[TD]RE: Maintenance SSRB 10/3/2012[/TD]
[TD="align: right"]10/4/2012 20:31[/TD]
[TD]Ferno.Lop@company.com[/TD]
[TD]Request Maintenance[/TD]
[/TR]
[TR]
[TD]RE: Requesting -9 Core SCR to be copied to PF[/TD]
[TD="align: right"]10/4/2012 20:01[/TD]
[TD]Deb.Rob@company.com[/TD]
[TD]Approved[/TD]
[/TR]
</tbody>[/TABLE]

Which I process and move the required rows to Two Different Sheets
1) Approved 2) InProcess

1) Approved Sheet (Done Manually)
Code: 
[TABLE="width: 861"]
<tbody>[TR]
[TD]Subject[/TD]
[TD]Received Date[/TD]
[TD]Sender[/TD]
[TD]Body (Edited)[/TD]
[/TR]
[TR]
[TD]Access[/TD]
[TD="align: right"]10/5/2012 1:13[/TD]
[TD]Karan.Gini@company.com[/TD]
[TD]Request - Access[/TD]
[/TR]
[TR]
[TD]Access[/TD]
[TD="align: right"]10/5/2012 1:18[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]ddg SCR splits[/TD]
[TD="align: right"]10/5/2012 2:11[/TD]
[TD]Deb.Rob@company.com[/TD]
[TD]Approved[/TD]
[/TR]
[TR]
[TD]ddg SCR splits[/TD]
[TD="align: right"]10/5/2012 5:32[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]DGR151 Change Request #1 *04-Oct*[/TD]
[TD="align: right"]10/5/2012 2:39[/TD]
[TD]Deb.Rob@company.com[/TD]
[TD]Approved[/TD]
[/TR]
[TR]
[TD]DGR151 Change Request #1 *04-Oct*[/TD]
[TD="align: right"]10/5/2012 5:46[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]DGR151 Change Request #2 *04-Oct*[/TD]
[TD="align: right"]10/5/2012 2:15[/TD]
[TD]Deb.Rob@company.com[/TD]
[TD]Approved[/TD]
[/TR]
[TR]
[TD]DGR151 Change Request #2 *04-Oct*[/TD]
[TD="align: right"]10/5/2012 5:38[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]Requesting -9 Core SCR to be copied to PF[/TD]
[TD="align: right"]10/4/2012 20:01[/TD]
[TD]Deb.Rob@company.com[/TD]
[TD]Approved[/TD]
[/TR]
[TR]
[TD]Requesting -9 Core SCR to be copied to PF[/TD]
[TD="align: right"]10/4/2012 21:14[/TD]
[TD]lee.franz@company.com[/TD]
[TD]Done[/TD]
[/TR]
[TR]
[TD]VBA_TPP_SP_DELAY.DOC - Element deletion needed[/TD]
[TD="align: right"]10/4/2012 21:05[/TD]
[TD]Christ.Rev@company.com[/TD]
[TD]Approved - Element Deletion[/TD]
[/TR]
[TR]
[TD]VBA_TPP_SP_DELAY.DOC - Element deletion needed[/TD]
[TD="align: right"]10/4/2012 21:09[/TD]
[TD]Karan.Gini@company.com[/TD]
[TD]Request - Rejected[/TD]
[/TR]
</tbody>[/TABLE]

2) InProcess Sheet (Done Manually)
Code: 
[TABLE="width: 861"]
<tbody>[TR]
[TD]Subject[/TD]
[TD]Received Date[/TD]
[TD]Sender[/TD]
[TD]Body (Edited)[/TD]
[/TR]
[TR]
[TD]element missing in the SCR[/TD]
[TD="align: right"]10/5/2012 3:19[/TD]
[TD]Aruna.Ria@company.com[/TD]
[TD]Request - Element Missing[/TD]
[/TR]
[TR]
[TD]Maintenance SSRB 10/3/2012[/TD]
[TD="align: right"]10/4/2012 20:31[/TD]
[TD]Ferno.Lop@company.com[/TD]
[TD]Request Maintenance[/TD]
[/TR]
[TR]
[TD]NDGR1[/TD]
[TD="align: right"]10/5/2012 0:07[/TD]
[TD]Jean.Le@company.com[/TD]
[TD]Request - NDGR1 Access[/TD]
[/TR]
[TR]
[TD]Please grant CONTROL privileges for -8[/TD]
[TD="align: right"]10/5/2012 1:01[/TD]
[TD]Tarnga.Voe@company.com[/TD]
[TD]Request - Controll Privileges[/TD]
[/TR]
[TR]
[TD]Please insert elemnt to LCT[/TD]
[TD="align: right"]10/5/2012 2:55[/TD]
[TD]Jitendar.Kuma@company.com[/TD]
[TD]Request - Insert Element[/TD]
[/TR]
</tbody>[/TABLE]

Manual Steps I do to segregate the data
Code: 
1    Sort by "Received Date" Ascending Order
2    Find and Remove "FW: " & "RE: " - To ensure all subject Lines are common
3    Sort by "Subject" Ascending Order
4    Identify the mails with (Subject Line), in which "Deb.Rob" or "Karan.Gini" involved (Sender)
5    "Copy the Mails which have the involvement of ""Deb.Rob"" or ""Karan.Gini"" to ""Approved Sheet" and Other Mails to "InProcess Sheet"

I'm doing this manually every day, which is taking much time and efforts, I get almost 100 to 150 requests and followup mails to be checked in.

I have a Macro to extract fields of entire Outlook Inbox, but No clue to segregate the data!

I need your help in automating this process. Please let me you know if you need any inputs. I'm attaching a sample file for your reference.

Thanks a million in advance

Sample_Outlook_File_Processed_Manually.xls
 
Sort by date Sort by votes
You can build it up in bits, to remove your manual steps one by one
1) create a small function to process the subject field to remove RE: and FW:
2) you will need to keep 2 counters introw and introw1 and 2 variables for the destination worksheet names, compare the email address and branch accordingly

Code: 
If name ="deb" or name ="Karen" then
  Wsname="approved"
  Introw = introw + 1
  Fill in rows
Else
 Wsname = "other"
 Introw1 = introw1 + 1
 Fill in rows
End if

2) add in code to sort by field1 and then by field2

Apologies this is in generic terms but I am on my ipad at the moment, so can't do any coding
 
Upvote 0
Hi jimrward Thanks for the reply, It sounds a bit clear, But I'm not sure how to do that:confused: Got struck!

If possible can you do that for me, once you get on your computer? Please...
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
Reverse Engineer Outlook Macro since New Outlook does not allow Macros
Replies
1
Views
401
John_w
J
D
  • Question Question
Move data from one sheet to mutlipe sheets based on sheet name
Replies
3
Views
730
Herakles
H
J
  • Question Question
VBA Code in Outlook to get unread emails
2
Replies
10
Views
17K
Coding4Fun
C
J
  • Question Question
VBA code not running the 2nd time
Replies
1
Views
915
Jacki
J
J
  • Locked
  • Question Question
VBA Macro not running the 2nd time
Replies
1
Views
652
Fluff
Fluff

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top