Moving over 20,000 emails, based on email address, freezes Outlook - vba

Question

I am trying to move over 20,000 emails, based on email address, into desired folders.
The code I found freezes Outlook. The code does work before the freeze.
Using first code from the answer to this post
Option Explicit
Public Sub Move_Items()
' // Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim olNs As Outlook.NameSpace
Dim Item As Object
Dim Items As Outlook.Items
Dim lngCount As Long
On Error GoTo MsgErr
' Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
' // Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items(lngCount)
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "Email_One#email.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder One")
Set Item = Items.Find("[SenderEmailAddress] = 'Email_One#email.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "Email_Two#email.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder Two")
Set Item = Items.Find("[SenderEmailAddress] = 'Email_Two#email.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
Also is it possible to filter not a specific email address e.g. dave#test.com but *#test.com?

Answer 1

I think at least your first problem might be the line 'Set Inbox = olNs.GetDefaultFolder(olFolderInbox)'
I have the similar line 'Set Items = objNS.GetDefaultFolder(olFolderInbox).Items' in my start-up routine Private Sub Application_Startup() . This worked fine ever since we switched to 365, but then circa February 2021 it started to crash on start-up. I got here by searching on this problem. Presumably they have changed something about the object model.
I also suppose it could be where olNs is set in the first place ' Set objNS = olApp.GetNamespace("MAPI"), if you mail doesn't use MAPI?
I've chucked the problem at out IT support, and I'll let you know if they come back with anything other than a mildly panicked 'what the hell you doing using VBA?'

Answer 2

The delay is caused by running a time-consuming task/code in Outlook. So, you need to optimize what and how is run in Outlook.
The problem is in the source code. I've noticed that you are iterating over all items in the folder:
// Loop through the Items in the folder backwards
For lngCount = Items.Count To 1 Step -1
That is completely a bad idea!
Instead, you need to use the Find/FindNext or Restrict methods to process all items that correspond to the specified search criteria. The Find method returns a single and first entry from the list of items. To get the second (if any) you need to use the FindNext method in the loop.
Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Also you may consider using the AdvancedSearch method of the Application class. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
See Advanced search in Outlook programmatically: C#, VB.NET for more information.

Answer 3

If processing every item there is no need for a Find. Find replaces the For loop item. It is more likely to run to completion when there are fewer items.
The simplest change is to remove the Find. This should fix any array out of bounds errors. Still it is inefficient.
// Email_One
Case "Email_One#email.com"
'// Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Folder One")
'// Mark As Read
Item.UnRead = False
'// Move Mail Item to sub Folder
Item.Move SubFolder
One way to limit processing to the applicable items.
Option Explicit
Public Sub Move_Items_Restrict()
'// Declare your Variables
Dim myInbox As Folder
Dim subFolder As Folder
Dim myItem As Object
Dim myItems As Items
Dim resItems As Items
Dim strfilter As String
Dim i As Long
' Not while developing
'On Error GoTo MsgErr
' Set Inbox Reference
Set myInbox = Session.GetDefaultFolder(olFolderInbox)
'// Email_One
Set myItems = myInbox.Items
strfilter = "[SenderEmailAddress] = 'Email_One#email.com'"
Debug.Print strfilter
' some of these work, fromemail does
' https://learn.microsoft.com/en-us/previous-versions/office/developer/exchange-server-2007/aa579702(v=exchg.80)
'strfilter = "#SQL=urn:schemas:httpmail:fromemail LIKE '%#test.com'"
'Debug.Print strfilter
Set resItems = myItems.Restrict(strfilter)
Debug.Print resItems.count
If resItems.count > 0 Then
'// Set SubFolder of Inbox
Set subFolder = myInbox.folders("Folder One")
For i = resItems.count To 1 Step -1
Set myItem = resItems(i)
With myItem
'// Mark As Read
.UnRead = False
'// Move Mail Item to sub Folder
.Move subFolder
End With
' If there is a memory error,
' release item when no longer necessary,
'Set myItem = Nothing
Next
End If
'// Email_Two
Set myItems = myInbox.Items
strfilter = "[SenderEmailAddress] = 'Email_Two#email.com'"
Debug.Print strfilter
Set resItems = myItems.Restrict(strfilter)
Debug.Print resItems.count
If resItems.count > 0 Then
'// Set SubFolder of Inbox
Set subFolder = myInbox.folders("Folder Two")
For i = resItems.count To 1 Step -1
Set myItem = resItems(i)
With myItem
' // Mark As Read
.UnRead = False
' // Move Mail Item to sub Folder
.Move subFolder
End With
' If there is a memory error,
' release item when no longer necessary,
'Set myItem = Nothing
Next
End If
MsgErr_Exit:
Exit Sub
'// Error information for users to advise the developer
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & err.Number _
& vbCrLf & "Error Description: " & err.description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub