Macro to extract required data from oulook message body to Excel

[RizwanShaikh]

Hi

i am new to this forum and seeking solution for my problem.

i have following code with me and its working.


Sub ExportToExcel()

On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim anum As Variant
Dim anum1 As Variant
Dim anum2 As Variant
Dim anum3 As Variant
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

strSheet = "Book.xlsx"
strPath = "C:\ErrorEmails\"
strSheet = strPath & strSheet

Debug.Print strSheet

'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

'Handle potential errors with Select Folder dialog box.

If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If

'Open and activate Excel workbook.

Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True

'Copy field items in mail folder.

For Each itm In fld.Items


intColumnCounter = 1
Set msg = itm
intColumnCounter = intColumnCounter + 1

Set rng = wks.Cells(intRowCounter, intColumnCounter)
anum = msg.Body
'anum = Replace(msg.Body, " ", "")
anum1 = Split(anum, "TIMESTAMP : ")
anum2 = Split(anum1(1), vbNewLine)
rng.Value = anum2(0)
intColumnCounter = intColumnCounter + 1

Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
End If

Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub

the above code is working and asks for the outlook folder to select and fetches values from each mail after keyword 'TIMESTAMP :' till the end on the line from message body and paste that value in cell of excel in sheet one.

i need following modifications done in code
1. paste data to different workshhets of excel based on different values of subjects of email.
2. search for perticular string value from the message body of email and want to perform some action based on the presence of that value



please help me.

Thanks.