Moving Emails in Outlook Folders to Subfolder with VBA? - excel

Question

I have exported all subject of the emails from the main folder to excel spreadsheet in the first module of my project.
For the second module, or code. I would like to move the emails i extracted from the main folder to a sub-folder based on searching the email subject. I detailed the subfolder name, on a separate column of the spreadsheet.
Column 3 - The subject email
Column 8 - The subfolder name
Each email subject in the main folder is unique, So i used the "Find Method" then move the email to the subfolder. Since the list is dynamic every time i make an extract, i decided to use arrays, so that it can iterate when the list of email changes.
Example, the code has to place email in the main folder with subject "A" to folder "1".
Email subject Folder name
(Column 3) (Column 8)
A 1
B 1
C 2
D 2
E 1
Sub MovingEmails_Invoices()
'Declare your Variables
Dim i As Object
Dim items As Outlook.items
Dim subfolder As Outlook.Folder 'this will be the folder you want to move the Mail to
'Set Outlook Inbox Reference
Set OP = New Outlook.Application
Set NS = OP.GetNamespace("MAPI")
'To loop through subfolder and its folders
Set rootfol = NS.Folders("SYNTHES-JNJCZ-GBS.DE.AT.CH#ITS.JNJ.com")
Set Folder = rootfol.Folders("Austria")
'The list for invoice numbers and folders is dynamic
'Each subject being searched is different
Dim Listmails() As Variant
Dim Rowcount As Variant
Dim Mailsubject As Variant
Dim FolderName As Variant
Dim MS As Variant
'Establish the array based on the mailbox extract
Sheets("files").Activate
Listmails = Range("A2").CurrentRegion
'Ititerate through the array which is dynamic (One-dimensional)
For Rowcount = LBound(Listmails) To UBound(Listmails)
'3rd row for email subject
Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
MS = "[subject] = '" & Mailsubject & "'"
'Find the email based on the array for email subject
Set i = items
Set i = Folder.items.Find(MS)
If i.Class = olMail Then
'8th row for folder name
FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
Set subfolder = rootfol.Folders(FolderName)
'If email is found then mark it as read
item.UnRead = False
'Move it to the subfolder based on the array for folder name
i.Move subfolder
End If
Next Rowcount
End Sub
I had an error to conduct the below code, but i am not sure why
If i.Class = olMail Then
I am adding an improved code for the iteration part alone. i have error for
Set items = items.Restrict(MS)
'Ititerate through the array which is dynamic (One-dimensional)
For Rowcount = LBound(Listmails) To UBound(Listmails)
'3rd row for email subject 'used DASL Filter
Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
MS = "urn:schemas:mailheader:subject LIKE \'%" & Mailsubject & "%\'"
'Find the email based on the array for email subject
Set myitems = Folder.items
Set myrestrictitem = myitems.Restrict(MS)
For Each i In myrestrictitem
If TypeOf i Is Mailitem Then
'8th row for folder name
FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
Set subfolder = rootfol.Folders(FolderName)
'If email found then mark it as read
i.UnRead = False
'Move it to the subfolder based on the array for folder name
i.Move subfolder
Else
End If
Next
Next Rowcount
End Sub

Answer 1

I'm just looking at part of your code, but there's at least two big mistakes I spotted:
Why are you setting i twice? Also what is items?
Set i = items
Set i = Folder.items.Find(MS)
1: Do you perhaps want to check the TypeOf i?
If i.Class = olMail Then
2: What is item?
item.UnRead = False
Remove the line
Set i = items
Replace the line
If i.Class = olMail then
with
If TypeOf i Is MailItem Then
And replace item with i in the line item.UnRead = False

Answer 2

I'd suggest checking the subject line as a substring, for example:
dim filter as string = "urn:schemas:mailheader:subject LIKE \'%"+ wordInSubject +"%\'"
Also, you must use the FindNext in addition to the Find one or just the Restrict method:
Sub MovingEmails_Invoices()
'Declare your Variables
Dim i As Object
Dim items As Outlook.items
Dim subfolder As Outlook.Folder 'this will be the folder you want to move the Mail to
'Set Outlook Inbox Reference
Set OP = New Outlook.Application
Set NS = OP.GetNamespace("MAPI")
'To loop through subfolder and its folders
Set rootfol = NS.Folders("SYNTHES-JNJCZ-GBS.DE.AT.CH#ITS.JNJ.com")
Set Folder = rootfol.Folders("Austria")
'The list for invoice numbers and folders is dynamic
'Each subject being searched is different
Dim Listmails() As Variant
Dim Rowcount As Variant
Dim Mailsubject As Variant
Dim FolderName As Variant
Dim MS As Variant
'Establish the array based on the mailbox extract
Sheets("files").Activate
Listmails = Range("A2").CurrentRegion
'Ititerate through the array which is dynamic (One-dimensional)
For Rowcount = LBound(Listmails) To UBound(Listmails)
'3rd row for email subject
Mailsubject = Application.WorksheetFunction.Index(Listmails, Rowcount, 3)
MS = "urn:schemas:mailheader:subject LIKE \'%"& Mailsubject &"%\'"
'Find the email based on the array for email subject
Set items = Folder.Items
Set items = items.Restrict(MS)
i = resultItems.GetFirst()
While Not IsNothing(i)
If i.Class = olMail Then
'8th row for folder name
FolderName = Application.WorksheetFunction.Index(Listmails, Rowcount, 8)
Set subfolder = rootfol.Folders(FolderName)
'If email is found then mark it as read
i.UnRead = False
'Move it to the subfolder based on the array for folder name
i.Move subfolder
i = resultItems.GetNext()
End While
End If
Next Rowcount
End Sub
You can find the sample code and description 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