Excel VBA to Fetch email addresses from inbox and sent items folders

Question

I am using the following VBA to fetch multiple specified Email addresses from inbox and sent items folder also including cc and bcc

for eg(gmail.com;yahoo.com) must return all mails having that domain name.

the problem is it takes a whole lot of time and I mean if a person has 2k emails (overall) he might have to wait for approx. 2 hours.

The internet speed isn't an issue and it gives desired output of specified email addresses.

Checked 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 don't 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

• HackSlash: Your code is really hard to read due to the random indentations and line breaks. Please use the RubberDuck to format your code before posting here. rubberduckvba.com Choose a style and stick with it. Usually, one line break between logical sections.

Answer 1

Performance

Each statement that references ActiveSheet is affecting the performance/speed. Rather than using the ActiveSheet repeatedly create a named sheet and assign that sheet to a sheet variable. Also create Range variables, all of the Select statements are affecting the performance. Any Select statements should be outside loops if possible.

Use With statements to speed up internal operations.

DRY Code

There is a programming principle called the Don't Repeat Yourself Principle sometimes referred to as DRY code. If you find yourself repeating the same code mutiple times it is better to encapsulate it in a function. If it is possible to loop through the code that can reduce repetition as well.

Complexity

There is only one subroutine, and when I copied the subroutine it was 241 lines long. The general rule in programming is that no function or subroutine should be larger than a single screen in an editor because it is too difficult to understand large subroutines or functions. Break the subroutine up into smaller subroutines or functions that do exactly one thing. Localize the variables to the subroutines they are needed in. There should probably be one subroutine for the Inbox and one subroutine for the Sent mails.

Another reason to break up the function is that it is very difficult to identify where any bottlenecks are (things that slow down the code) in a large subroutine.

There is also a programming principle called the Single Responsibility Principle that applies here. The Single Responsibility Principle states:

that every module, class, or function should have responsibility over a single part of the functionality provided by the software, and that responsibility should be entirely encapsulated by that module, class or function.

The art or science of programming is to break problems into smaller and smaller pieces until each piece is very simple to code.

• DeepnilVasava: got to know many ways and points from you . will look this things into it .