VBA fetching emails from outlook too slow

Question

So apparently here this macro fetches specific email addresses from inbox as well as sent items along with email addresses from cc,bcc
the problem is it takes a whole lot of time and i mean if a person has 2k emails he might have to wait for 3 to 4 hours.
Check some sources how to make code faster i got to know about restrict function when applied through DASL filter and limit number of items in a loop. i applied the same but the result is still the same and fetching is still slow.
As new into VBA i dont know all about optimization and still learning.

Any other sources or ways to make the fetching and execution faster?

code given for reference

Option Explicit

Sub GetInboxItems()
'all vars declared
    Dim ol As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fol As Outlook.Folder
    Dim i As Object
    Dim mi As Outlook.MailItem
    Dim n As Long
    Dim seemail As String
    Dim seAddress As String
    Dim varSenders As Variant
      
      'for sent mails
    Dim a As Integer
    Dim b As Integer
    Dim objitem As Object
    Dim take As Outlook.Folder
    Dim xi As Outlook.MailItem
    Dim asd As String
    Dim arr As Variant
    Dim K As Long
    Dim j As Long
    Dim vcc As Variant
    Dim seemail2 As String
    Dim seAddress2 As String
    Dim varSenders2 As Variant
    Dim strFilter As String
    Dim strFilter2 As String
   'screen wont refresh untill this is turned true
   
    Application.ScreenUpdating = False
    
   'now assigning the variables and objects of outlook into this
    Set ol = New Outlook.Application
    Set ns = ol.GetNamespace("MAPI")
    Set fol = ns.GetDefaultFolder(olFolderInbox)
    Set take = ns.GetDefaultFolder(olFolderSentMail)
    
    
    
    
    
    Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear
    
    n = 2
    
    
    strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " like '%" & seemail & "'"
    strFilter2 = "@SQL=" & Chr(34) & "urn:schemas:httpmail:sentitems" & Chr(34) & " like '%" & seemail2 & "'"
    'this one is for sent items folder where it fetches the emails from particular people
     For Each objitem In take.Items.Restrict(strFilter2)
    
    
        If objitem.Class = olMail Then
        
            Set xi = objitem
            
            n = n + 1
            
            seemail2 = Worksheets("Inbox").Range("D1")
             varSenders2 = Split(seemail2, ";")
             
              For K = 0 To UBound(varSenders2)
             
             
             'this is the same logic as the inbox one where if mail is found and if the mail is of similar kind then and only it will return the same
                If xi.SenderEmailType = "EX" Then
                    seAddress2 = xi.Sender.GetExchangeUser.PrimarySmtpAddress
                    If InStr(1, seAddress2, varSenders2(K), vbTextCompare) Then
                    Cells(n, 1).Value = xi.Sender.GetExchangeUser().PrimarySmtpAddress
                    Cells(n, 2).Value = xi.SenderName
                    ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                    On Error Resume Next
                        Range("A3:A9999").Select
                        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                     End If
                     'this is the smpt address (regular address)
                     ElseIf xi.SenderEmailType = "SMTP" Then
                    seAddress2 = xi.SenderEmailAddress
                    If InStr(1, seAddress2, varSenders2(K), vbTextCompare) Then
                        Cells(n, 1).Value = xi.SenderEmailAddress
                        Cells(n, 2).Value = xi.SenderName
                       
                       ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                       On Error Resume Next
                           Range("A3:A9999").Select
                           Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                         End If
                         'this one fetches the cc part recipient denotes cc
                         For j = xi.Recipients.Count To 1 Step -1
                    
                    
                    If (xi.Recipients.Item(j).AddressEntry.Type = "EX") Then
                            vcc = xi.Recipients.Item(j).Address
                            If InStr(1, vcc, varSenders2(K), vbTextCompare) Then
                                Cells(n, 1).Value = xi.Recipients.Item(j).AddressEntry.GetExchangeUser.PrimarySmtpAddress
                                Cells(n, 2).Value = xi.Recipients.Item(j).Name
                            ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                            On Error Resume Next
                           Range("A3:A9999").Select
                           Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                            End If
                            
                    Else
                    vcc = xi.Recipients.Item(j).Address
                            
                            If InStr(1, vcc, varSenders2(K), vbTextCompare) Then
                                  Cells(n, 1).Value = xi.Recipients.Item(j).Address
                                  Cells(n, 2).Value = xi.Recipients.Item(j).Name
                            ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                            On Error Resume Next
                           Range("A3:A9999").Select
                           Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                            End If
                            
                            End If
                            
                            Next j
                            
                    Else: seAddress2 = ""
                    End If
                    
                    
                    
                    For a = 1 To take.Items.Count
                    n = 3
                    
                        'this also fetches the recipient emails
                    If TypeName(take.Items(a)) = "MailItem" Then
                    
                    For b = 1 To take.Items.Item(a).Recipients.Count
                        asd = take.Items.Item(a).Recipients(b).Address
                    If InStr(1, asd, varSenders2(K), vbTextCompare) Then
                        Cells(n, 1).Value = asd
                        Cells(n, 2).Value = take.Items.Item(a).Recipients(b).Name
                        n = n + 1
                        End If
                        
                        Next b
                        End If
                        Next a
                    
                    
                    
                    
                    Next K
                    
               End If
        Next objitem
                          
    
    
    For Each i In fol.Items.Restrict(strFilter)
    
        If i.Class = olMail Then
        
            Set mi = i
            'objects have been assigned and can be used to fetch emails
             seemail = Worksheets("Inbox").Range("D1")
             varSenders = Split(seemail, ";")
            
            n = n + 1
            
            For K = 0 To UBound(varSenders)

            'similar logic as above
            
            If mi.SenderEmailType = "EX" Then
                    seAddress = mi.Sender.GetExchangeUser().PrimarySmtpAddress
                    If InStr(1, seAddress, varSenders(K), vbTextCompare) Then
                   Cells(n, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress
                   Cells(n, 2).Value = mi.SenderName
                    ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                    On Error Resume Next
                        Range("A3:A9999").Select
                        Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                        End If
                        
                        
            ElseIf mi.SenderEmailType = "SMTP" Then
                    seAddress = mi.SenderEmailAddress
                    If InStr(1, seAddress, varSenders(K), vbTextCompare) Then
                       Cells(n, 1).Value = mi.SenderEmailAddress
                       Cells(n, 2).Value = mi.SenderName
                       
                       ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                       On Error Resume Next
                           Range("A3:A9999").Select
                           Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                       End If
                       
                       
                       
                       
                       
        For j = mi.Recipients.Count To 1 Step -1
                    If (mi.Recipients.Item(j).AddressEntry.Type = "EX") Then
                            vcc = mi.Recipients.Item(j).Address
                            If InStr(1, vcc, varSenders(K), vbTextCompare) Then
                                    Cells(n, 1).Value = mi.Recipients.Item(j).AddressEntry.GetExchangeUser.PrimarySmtpAddress
                                    Cells(n, 2).Value = mi.Recipients.Item(j).Name
                            ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                            On Error Resume Next
                           Range("A3:A9999").Select
                           Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                            End If
                            
                    Else
                    vcc = mi.Recipients.Item(j).Address
                            If InStr(1, vcc, varSenders(K), vbTextCompare) Then
                                   Cells(n, 1).Value = mi.Recipients.Item(j).Address
                                   Cells(n, 2).Value = mi.Recipients.Item(j).Name
                            ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                            On Error Resume Next
                           Range("A3:A9999").Select
                           Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                            End If
                            End If
                            Next j
                            
    Else: seAddress = ""
     End If
           Next K
        End If
        
        
    Next i
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
                            On Error Resume Next
                           Range("A3:A9999").Select
                           Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
                           

     Set take = Nothing
     Set mi = Nothing
     

    Application.ScreenUpdating = True
End Sub

Answer 1

All the code touching the email from the outer loop should be taken out of the inner loop. Eg the line like

seAddress2 = xi.Sender.GetExchangeUser.PrimarySmtpAddress

has no business being in the inner loop.

I also wouldn't call RemoveDuplicates on each step of the loop.

Also, most likely the senders won't be unique - retrieve all the sender addresses ( SenderEmailAddress ) in a single using MAPIFolder.GetTable and build a dictionary of EX type addresses vs SMTP addresses ( GetExchangeUser.PrimarySmtpAddress ) to be calculated only once for each unique address instead of retrieving it over and over again.

Answer 2

You have to assign a value to seemail and seemail2 before using in strFilter and strFilter2 .

Option Explicit

Sub GetInbox_And_SentItems()

    'Early binding - requires reference to Microsoft Outlook XX.X Object Library
    
    Dim ol As Outlook.Application
    Dim ns As Outlook.Namespace
    
    Dim fol As Outlook.Folder
    Dim folItem As Object
    Dim mi As Outlook.mailItem
    
    Dim n As Long
    
    Dim seemail As String
    Dim seAddress As String
    Dim varSenders As Variant
      
    'for sent mails
    Dim b As Integer
    Dim objitem As Object
    Dim take As Outlook.Folder
    Dim xi As Outlook.mailItem
    
    Dim k As Long
    
    Dim seemail2 As String
    Dim seAddress2 As String
    'Dim varSenders2 As Variant
    Dim varReceivers As Variant
    
    Dim strFilter As String
    Dim strFilter2 As String
    
    'screen won't refresh until this is turned true
    'Application.ScreenUpdating = False
    
    'now assigning the variables and objects of outlook into this
    Set ol = New Outlook.Application
    Set ns = ol.GetNamespace("MAPI")
    Set fol = ns.GetDefaultFolder(olFolderInbox)
    Set take = ns.GetDefaultFolder(olFolderSentMail)
    
    'Range("A3", Range("A3").End(xlDown).End(xlToRight)).Clear
    Range("A3:A9999").Select
    Selection.EntireRow.Delete
    n = 2
    
    varReceivers = Split(Worksheets("Inbox").Range("D1"), ";")
    
    For k = LBound(varReceivers) To UBound(varReceivers)
        
        seemail2 = Trim(varReceivers(k))
        Debug.Print seemail2
         
        ' Note displayto not fromemail
        '  displayto can be a difficult value
        '  https://stackoverflow.com/questions/16286694/using-the-restrict-method-in-outlook-vba-to-filter-on-single-recipient-email-ad
        ' As far as I know there is no working toemail.
        strFilter2 = "@SQL=" & Chr(34) & "urn:schemas:httpmail:displayto" & Chr(34) & " like '%" & seemail2 & "'"
        Debug.Print strFilter2
        
        Debug.Print "Items in Inbox.........:" & take.Items.Count
        Debug.Print "Filtered Items in Inbox:" & take.Items.Restrict(strFilter2).Count
        
        'this one is for sent items folder where it fetches the emails --> to  <-- particular people
        ' there is no point searching a sent folder for sender information
        For Each objitem In take.Items.Restrict(strFilter2)
        
            If objitem.Class = olMail Then
            
                Set xi = objitem
                n = n + 1
             
                Cells(n, 1).Value = seemail2
                Cells(n, 2).Value = xi.Subject
                
                Dim msg As String
                msg = ""
                For b = 1 To xi.Recipients.Count
                    msg = msg & xi.Recipients(b).Address & "; "
                Next b
                        
                Cells(n, 3).Value = msg
                    
            End If
        Next objitem
    Next k
    
    
    varSenders = Split(Worksheets("Inbox").Range("D1"), ";")
    
    For k = LBound(varSenders) To UBound(varSenders)
    
        seemail = Trim(varSenders(k))
        Debug.Print seemail
        
        strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & Chr(34) & " like '%" & seemail & "'"
        Debug.Print strFilter
                    
        For Each folItem In fol.Items.Restrict(strFilter)
        
            If folItem.Class = olMail Then
            
                Set mi = folItem
                'objects have been assigned and can be used to fetch emails
                
                n = n + 1

                'similar logic as above
                If mi.SenderEmailType = "EX" Then
                    seAddress = mi.Sender.GetExchangeUser().PrimarySmtpAddress
                    
                    Cells(n, 1).Value = mi.Sender.GetExchangeUser().PrimarySmtpAddress
                    Cells(n, 2).Value = mi.SenderName
                    
                ElseIf mi.SenderEmailType = "SMTP" Then
                    seAddress = mi.SenderEmailAddress
                    
                    Cells(n, 1).Value = mi.SenderEmailAddress
                    Cells(n, 2).Value = mi.Subject
                    
                End If
            End If
        Next folItem
    Next k
    
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    
    'Uncomment if needed
    'On Error Resume Next
    Range("A3:A9999").Select
    Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    
End Sub