VBA 从 Outlook 中获取电子邮件太慢
VBA fetching emails from outlook too slow
很明显这个宏从收件箱中获取特定的电子邮件地址以及已发送的项目以及来自抄送、密件抄送的电子邮件地址
问题是这需要很多时间，我的意思是如果一个人有 2k 封电子邮件，他可能需要等待 3 到 4 个小时。
检查一些来源如何使代码更快 我了解了通过 DASL 过滤器应用限制功能并限制循环中的项目数。我应用了相同的方法，但结果仍然相同，而且获取速度仍然很慢。
作为 VBA 的新手，我对优化一窍不通，还在学习中。
任何其他来源或方法可以加快获取和执行速度？
代码供参考
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
外循环中涉及电子邮件的所有代码都应从内循环中取出。例如。这条线像
seAddress2 = xi.Sender.GetExchangeUser.PrimarySmtpAddress
没有必要进入内部循环。
我也不会在循环的每一步都调用 RemoveDuplicates。
此外，发件人很可能不会是唯一的 - 使用 MAPIFolder.GetTable 一次性检索所有发件人地址 (SenderEmailAddress) 并构建 EX 类型地址与 SMTP 地址的字典（ GetExchangeUser.PrimarySmtpAddress) 只为每个唯一地址计算一次，而不是一遍又一遍地检索它。
您必须先为 seemail 和 seemail2 赋值，然后才能在 strFilter 和 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
'
' 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
很明显这个宏从收件箱中获取特定的电子邮件地址以及已发送的项目以及来自抄送、密件抄送的电子邮件地址
问题是这需要很多时间，我的意思是如果一个人有 2k 封电子邮件，他可能需要等待 3 到 4 个小时。
检查一些来源如何使代码更快 我了解了通过 DASL 过滤器应用限制功能并限制循环中的项目数。我应用了相同的方法，但结果仍然相同，而且获取速度仍然很慢。
作为 VBA 的新手，我对优化一窍不通，还在学习中。
任何其他来源或方法可以加快获取和执行速度？
代码供参考
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
外循环中涉及电子邮件的所有代码都应从内循环中取出。例如。这条线像
seAddress2 = xi.Sender.GetExchangeUser.PrimarySmtpAddress
没有必要进入内部循环。
我也不会在循环的每一步都调用 RemoveDuplicates。
此外，发件人很可能不会是唯一的 - 使用 MAPIFolder.GetTable 一次性检索所有发件人地址 (SenderEmailAddress) 并构建 EX 类型地址与 SMTP 地址的字典（ GetExchangeUser.PrimarySmtpAddress) 只为每个唯一地址计算一次，而不是一遍又一遍地检索它。
您必须先为 seemail 和 seemail2 赋值，然后才能在 strFilter 和 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
'
' 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