Outlook code works, but really slow. How to make it faster?

P

pupsia

Board Regular
Joined
Dec 2, 2015
Messages
67
Hello everyone :)

The code I`m using at the moment works and I get the needed data. BUT, unfortunately, the code is really slow...

I use the macro to select a folder in Outlook and then extract all email information (name, sender, reviser and so on.), based on a week. So basically, a weekly statistic. In another sheet there is a list of folders that need to be ignored.

The code is really long... And I`m sure there are a lot of parts that need to be changed... Please help...
Shared email boxes take a lot longer then my personal as well.
Tried it with 4 email boxes:
Personal email box - took about 1 minute.
1 shared email box - took more then 5 min.
2 shared email box - took more then 4 min.
3 shared email box - after 25 minutes I stopped the program... It was taking way to long..

I`m attaching my whole code:

Code: 
Sub Launch_Pad()
     
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
     
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    Application.ScreenUpdating = False
    If ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row > 2 Then n = ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row Else n = 2
    Set report = ThisWorkbook.Sheets("Report")
    'n = 2
    'Cells.ClearContents
     
    Call ProcessFolder(olFolder)
    Call DovydasUpgrade
    'Call statistika_tutita
     
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olApp = Nothing
    Set olNS = Nothing
    
    Application.ScreenUpdating = True
    AppActivate Application.Caption 'grazina exceli i prieki
    MsgBox "Completed."
End Sub



Sub ProcessFolder(olfdStart As Outlook.MAPIFolder)
    Dim subfolderis As Outlook.MAPIFolder
    Dim olFolder As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    'Set report = ThisWorkbook.Sheets("Report")
      
   
    week = report.OptionButtons("Option Button 2").Value 'for week
    daily = report.OptionButtons("Option Button 3").Value 'for day
     
    If n = 2 Then
        report.Range("A" & n).Value = "Subject"
        report.Range("B" & n).Value = "SenderName"
        report.Range("C" & n).Value = "To"
        report.Range("D" & n).Value = "Folder name"
        report.Range("E" & n).Value = "Categories"
        report.Range("F" & n).Value = "ReceivedTime"
        report.Range("G" & n).Value = "Conversation ID"
        
        
        report.Range("A2:G2").Style = "Accent1"
    End If
                    
                    
'On Error Resume Next
'AppActivate Application.Caption ' grazina excelio langa kaip active
    If week = xlOn Then
    AppActivate Application.Caption ' grazina excelio langa kaip active
        SiosSavNr = WeekNumberAbsolute(Format(Now()))
        SavaitesNR = InputBox(Prompt:="Pleas enter Week # as today we have " & SiosSavNr & "th one.", Title:="Week number?", Default:=SiosSavNr)
        
        Call laiskams(olfdStart, SavaitesNR) ' kviecia likusias funkcijas
    End If
    
    
    If daily = xlOn Then Call laiskams(olfdStart, SavaitesNR)
    report.Columns("F:F").NumberFormat = "d/m/yy h:mm;@"
    report.Range("A2:G2").AutoFilter
    Set olMail = Nothing
    Set olFolder = Nothing
    'Set olObject = Nothing
End Sub



Function MailItemExport(olMail As Outlook.MailItem)
    
    n = n + 1
    Application.StatusBar = olMail.ReceivedTime
    report.Range("A" & n) = olMail.Subject
    report.Range("B" & n) = olMail.SenderName
    report.Range("C" & n) = olMail.To & "; " & olMail.CC
    report.Range("D" & n) = olMail.Parent.Name
    report.Range("E" & n) = olMail.Categories
    report.Range("F" & n) = olMail.ReceivedTime
    report.Range("G" & n) = olMail.ConversationID
    'report.Range("N" & n) = olMail.Parent.Name
    'report.Range("O" & n) = olMail.SentOnBehalfOfName
    'report.Range("P" & n) = olMail.ReplyRecipientNames
    report.Range("R" & n) = olMail.LastModificationTime


End Function



Function laiskams(olfdStart, SavaitesNR)
    Dim olObject As Object
    Set report = ThisWorkbook.Sheets("Report")
    week = report.OptionButtons("Option Button 2").Value 'for week
    daily = report.OptionButtons("Option Button 3").Value 'for day




            For Each olObject In olfdStart.Items                            'kala per visus root item'us
              If TypeName(olObject) = "MailItem" Then
                'If Err > 0 Then Err.Clear: GoTo kitas31
                    Application.StatusBar = olObject.Parent.Name & " " & olObject.ReceivedTime


                    If daily = xlOn Then
                        If Val(DateDiff("d", olObject.ReceivedTime, Now)) <= 7 Then Call MailItemExport(olObject) 'tikrina kad per 7 dienas butu
                    End If
                    If week = xlOn Then
                        If WeekNumberAbsolute(olObject.ReceivedTime) = SavaitesNR Then Call MailItemExport(olObject)
                    End If
              End If
kitas31:
            Next olObject
            Call folderiams(olfdStart, SavaitesNR)
End Function



Sub DovydasUpgrade()


Dim lrow, taip As Long, report As Worksheet
Set report = ThisWorkbook.Sheets("Report")
lrow = ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row




'sort'as
    report.Sort.SortFields.Clear
    report.Sort.SortFields.Add Key:=Range("G3:G" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    report.Sort.SortFields.Add Key:=Range("F3:F" & lrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With report.Sort
        .SetRange Range("A2:G" & lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


'gimdom
For taip = 4 To lrow
    If taip = 4 Then report.Range("A3:G3").Style = "20% - Accent5"
    
    If report.Range("G" & taip).Value = report.Range("G" & taip - 1).Value Then 'jei sutampa paliekam
        If report.Range("A" & taip - 1 & ":G" & taip - 1).Style = "20% - Accent5" Then report.Range("A" & taip & ":G" & taip).Style = "20% - Accent5"
        If report.Range("A" & taip - 1 & ":G" & taip - 1).Style = "40% - Accent5" Then report.Range("A" & taip & ":G" & taip).Style = "40% - Accent5"
    End If
    If report.Range("G" & taip).Value <> report.Range("G" & taip - 1).Value Then 'jei sutampa paliekam
        If report.Range("A" & taip - 1 & ":G" & taip - 1).Style = "20% - Accent5" Then report.Range("A" & taip & ":G" & taip).Style = "40% - Accent5"
        If report.Range("A" & taip - 1 & ":G" & taip - 1).Style = "40% - Accent5" Then report.Range("A" & taip & ":G" & taip).Style = "20% - Accent5"
    End If
Next taip
report.Columns("A:B").EntireColumn.AutoFit
report.Columns("D:G").EntireColumn.AutoFit


End Sub



Public Function CountUnique(rng As Range) As Integer 'reikalauja microsoft scripting runtime library
        Dim dict As Dictionary
        Dim cell As Range
        Set dict = New Dictionary
        For Each cell In rng.Cells.SpecialCells(xlCellTypeVisible)
             If Not dict.Exists(cell.Value) Then
                dict.Add cell.Value, 0
            End If
        Next
        CountUnique = dict.Count
    End Function



Function folderiams(olfdStart, SavaitesNR)
Dim subfolderis As Outlook.MAPIFolder


excludablefolders = Application.WorksheetFunction.TextJoin("|", True, ThisWorkbook.Sheets("Email_List").Range("E2:E" & ThisWorkbook.Sheets("Email_List").Range("E" & Rows.Count).End(xlUp).Row))


        If olfdStart.Folders.Count > 0 Then             'jei folderiu yra
            For Each subfolderis In olfdStart.Folders   'kala per visus folderius
                If InStr(excludablefolders, subfolderis.Name) = 0 Then Call laiskams(subfolderis, SavaitesNR) ' jei vardas nera nereikalingu sarase - lendam i folderi
            Next subfolderis
        End If


End Function



Option Explicit
Dim n As Long
    Dim SavaitesNR As Integer, SiosSavNr As Variant, SelectedMonth As Variant
    Dim week As Long, daily As Long, StartData As String, report As Worksheet
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
I tested a few more times and I think the problem is with this part, it works the longest. Any idea why? And how to fix it?

Code: 
Function laiskams(olfdStart, SavaitesNR)
    Dim olObject As Object
    Set report = ThisWorkbook.Sheets("Report")
    week = report.OptionButtons("Option Button 2").Value 'for week
    daily = report.OptionButtons("Option Button 3").Value 'for day




            For Each olObject In olfdStart.Items                            'kala per visus root item'us
              If TypeName(olObject) = "MailItem" Then
                'If Err > 0 Then Err.Clear: GoTo kitas31
                    Application.StatusBar = olObject.Parent.Name & " " & olObject.ReceivedTime


                    If daily = xlOn Then
                        If Val(DateDiff("d", olObject.ReceivedTime, Now)) <= 7 Then Call MailItemExport(olObject) 'tikrina kad per 7 dienas butu
                    End If
                    If week = xlOn Then
                        If WeekNumberAbsolute(olObject.ReceivedTime) = SavaitesNR Then Call MailItemExport(olObject)
                    End If
              End If
kitas31:
            Next olObject
            Call folderiams(olfdStart, SavaitesNR)
End Function
 
Upvote 0
If there is no way to make the macro work faster, maybe there is some other way to write it?
 
Upvote 0
Hello Peter_SSs ,
Sorry to bother you, maybe you might have any ideas about this code? I`m not even sure in what direction I should go to make it faster..
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
Code works, but really slow. How to make it faster?
2
Replies
11
Views
1K
pupsia
P

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

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