Hi Team,
I've this below piece of code which extracts email details for any specific date or all the dates from a specific folder and puts in excel, which runs perfectly fine.
But the problem is I have more than 1 lac+ emails in the folder, and when I run the macro for any specific date it takes way to long to run.
I know since the emails are in huge numbers it would be slow, but can any one suggest some way which can reduce the run time?
Code
Public Sub ReadOutlookEmails()
'Microsoft Outlook XX.X Object Library is required to run this code
Sheet2.Rows("2:1048576").ClearContents
If Worksheets("Run").Range("G3").Value <> "" Then
Dim mail_date As Date
date_filter = "Yes"
On Error GoTo ErrorMessage1
mail_date = Worksheets("Run").Range("G3").Value
Else
date_filter = "No"
End If
Dim objFolder As Outlook.Folder
Dim objNS As Outlook.Namespace
Dim objMail As Outlook.MailItem
Dim lCounter As Long
Set objNS = Outlook.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
If TypeName(objFolder) = "Nothing" Then
Exit Sub
End If
Sheet2.Range("A1").Value = "Sender"
Sheet2.Range("B1").Value = "To"
Sheet2.Range("C1").Value = "Cc"
Sheet2.Range("D1").Value = "Subject"
Sheet2.Range("E1").Value = "Received Date"
Sheet2.Range("F1").Value = "Received Time"
Sheet2.Range("G1").Value = "No of attachements"
Sheet2.Range("H1").Value = "Body"
For lCounter = 1 To objFolder.Items.Count
'On Error GoTo ErrorMessage
On Error Resume Next
Set objMail = objFolder.Items.Item(lCounter)
If date_filter = "No" Then
'On Error GoTo ErrorMessage
Sheet2.Range("A" & lCounter + 1).Value = objMail.SenderName 'Sender name
Sheet2.Range("B" & lCounter + 1).Value = objMail.To 'To
Sheet2.Range("C" & lCounter + 1).Value = objMail.CC 'Cc
Sheet2.Range("D" & lCounter + 1).Value = objMail.Subject 'Subject
Sheet2.Range("E" & lCounter + 1).Value = objMail.ReceivedTime 'Email Received Time
Sheet2.Range("F" & lCounter + 1).Value = Format(CDate(objMail.ReceivedTime), "HH:MM:SS") 'Email Received Time
Sheet2.Range("G" & lCounter + 1).Value = objMail.Attachments.Count 'Attachment Count
Sheet2.Range("H" & lCounter + 1).Value = objMail.Body 'Attachment Count
'MsgBox objMail.Actions
'Sheet2.Range("I" & lCounter + 1).Value = objMail.Actions
Sheet2.Range("J" & lCounter + 1).Value = objMail.Categories
Sheet2.Range("K" & lCounter + 1).Value = objMail.FlagRequest
Sheet2.Range("L" & lCounter + 1).Value = objMail.Importance
Sheet2.Range("M" & lCounter + 1).Value = objMail.UnRead
'MsgBox objMail.ReceivedTime
ElseIf Format(CDate(objMail.ReceivedTime), "DD-MM-YYYY") = Format(mail_date, "DD-MM-YYYY") Then
'On Error GoTo ErrorMessage
i = i + 1
Set objMail = objFolder.Items.Item(lCounter)
Sheet2.Range("A" & i + 1).Value = objMail.SenderName 'Sender name
Sheet2.Range("B" & i + 1).Value = objMail.To 'To
Sheet2.Range("C" & i + 1).Value = objMail.CC 'Cc
Sheet2.Range("D" & i + 1).Value = objMail.Subject 'Subject
Sheet2.Range("E" & i + 1).Value = objMail.ReceivedTime 'Email Received Time
Sheet2.Range("F" & i + 1).Value = Format(CDate(objMail.ReceivedTime), "HH:MM:SS") 'Email Received Time
Sheet2.Range("G" & i + 1).Value = objMail.Attachments.Count 'Attachment Count
Sheet2.Range("H" & i + 1).Value = objMail.Body 'Attachment Count
Sheet2.Range("I" & lCounter + 1).Value = objMail.Actions
Sheet2.Range("J" & lCounter + 1).Value = objMail.Categories
Sheet2.Range("K" & lCounter + 1).Value = objMail.FlagRequest
Sheet2.Range("L" & lCounter + 1).Value = objMail.Importance
Sheet2.Range("M" & lCounter + 1).Value = objMail.UnRead
'ErrorMessage:
End If
Next
MsgBox "Please select the folder to save the summary." _
, vbInformation
ErrorMessage1:
'MsgBox "Please eneter a valid date, else leave it empty!", vbInformation
Range("G3").Activate
Save_Data
End Sub
Display More