Problem
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
Solution
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.