Moving Emails in Outlook Folders to Subfolder with VBA?

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