Reduce run time of macro

KhushalJain · Apr 21st 2021

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

**alansidman** · Apr 21st 2021

For starters, I would add at the beginning

Code

Application.ScreenUpdating = False

and before End Sub

Code

Application.ScreenUpdating = True

additionally, you may wish to turn automatic calculations off

**Kenneth Hobson** · Apr 22nd 2021

Maybe something like this but you may want to add the filter by date. I was not sure what you wanted with that. I removed some things so I could work up this example.

Code

Sub ReadOutlookEmails3()
  'Tools > References... > Microsoft Outlook 16.0 Object Library
  Dim objFolder As Outlook.Folder, objNS As Outlook.Namespace
  Dim ws As Worksheet, tCount As Long, oItem As Object, a
  Dim i As Integer, j As Integer, k As Integer
  
  Set objNS = Outlook.GetNamespace("MAPI")
  Set objFolder = objNS.PickFolder
  AppActivate ThisWorkbook.Application.Caption
  If TypeName(objFolder) = "Nothing" Then Exit Sub
  
  tCount = 0
  For Each oItem In objFolder.Items
    'If TypeName(oItem) = "MailItem" Then
    If oItem.Class = olMail Then  'does same as above
      tCount = tCount + 1
    End If
  Next oItem

  If tCount = 0 Then Exit Sub
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  
  k = 13 'Number of columns
  ReDim a(1 To tCount, 1 To k)
  Set ws = Worksheets("Sheet2")
  With ws
    .UsedRange.ClearContents
    'Set column/header row 1 values
    .Range("A1:M1") = Split("Sender,To,Cc,Subject,Received Date,Received Time," _
      & "No of attachements,Body,Actions,Categories,FlagRequest,Importance,UnRead", ",")
  End With

  On Error Resume Next
  tCount = 0
  For Each oItem In objFolder.Items
    'If TypeName(oItem) = "MailItem" Then
    If oItem.Class = olMail Then
      tCount = tCount + 1
      For i = 1 To k
        With oItem
          a(tCount, i) = Choose(i, .SenderName, .To, .CC, .Subject, .ReceivedTime, _
            Format(CDate(.ReceivedTime), "HH:MM:SS"), .Attachments.Count, _
            .Body, .Actions, .Categories, .FlagRequest, .Importance, .UnRead)
        End With
      Next i
    End If
  Next oItem
  
  ws.Range("A2").Resize(tCount, 13) = a
  ws.UsedRange.EntireColumn.AutoFit
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic

  MsgBox "done"
End Sub

Display More

Reduce run time of macro

Participate now!

Share

Tags