Microsoft Outlook 2013 to 2019 - VisualBasic MACRO ?

finance_teacher used Ask the Experts™
I need an Outlook 2013 to 2019 MACRO that MOVES
emails to a folder ONLY after I request the move
since I have 200+ folders and don't want to
manually drag items into their associated folders ?

Example #1
1. View new email from "Jane Doe"
2. Click "Move to Person's Folder" Toolbar ICON
3. Outlook automatically CREATES "Inbox/Jane Doe"
   folder if need and moves it there

1. View new email from "Bob Smith"
2. Click "Move to Person's Folder" Toolbar ICON
3. Outlook automatically CREATES "Inbox/Bob Smith"
   folder if need and moves it there
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2016

Why don't you just use rules?


Do you have some type of RULE that will do this without me having to create 200+ rules for the 200+ people that email me ?

No, could probably make a script which makes you a rule - i.e. first time you click on "file" button for Mr X it files it in the Mr X folder.  I haven't tried massive amounts of rules in current Outlook versions but there did used to be a limit on number of rules, a quick google looks like probably still the same though not a specific number and probably OK for 100-200 simple rules.

Main rule advantage is your emails are pre-filed for you and show as unread in the folder, but also automatically in the folders already if looking in web browser or through mobile device etc.

i extenisvely use the 'file it in relevant folder' method and delete the rubbish method (about 180,000 messages, 6Gb from 1996 onwards ) but see others using the "never deleted anything or file anything" and just searching the inbox... both have their merits.

Consultant and developer
You can replicate the effect of a rule by accessing the application.newmail event via a class module. Newmail triggers every time new mail arrives.

However, if you want to control the process more manually, the code below does most of what you want. It doesn't create folders for new names -- but moves emails based on email address to pre-defined folder. Would be easy to tweak to do the folder creation as well.

There are two routines: Distribute2Folders, and Findfolder, which is called by the first one.

It also uses a simple "userform" to keep track of what it is doing, which I've attached as an external file, which you can import to Outlook. Or you can comment out all the references to "udist".

Does this help.

Sub Distribute2Folders()
'moves all inbox items to sub-folders if email sender is found in sub-folder
Dim ff As Outlook.Folder, fInbox As Outlook.Folder
Dim oItems As Items, oThis As MailItem
Dim i As Long
Dim sEmail As String

'initialise user form uDist
uDist.lAction.Caption = "Sorting email"
uDist.lAction.Visible = True

'get inbox
Set fInbox = Session.GetDefaultFolder(olFolderInbox)
'select all items
Set oItems = fInbox.Items
'sort inbox items by email address, in reverse
oItems.Sort "SenderEmailAddress", True
'move backwards through list
i = oItems.Count
    'only handle mail items
    If TypeName(oItems(i)) = "MailItem" Then
    Set oThis = oItems(i)
        'if email address is different from previous:
        If oThis.SenderEmailAddress <> sEmail Then
        sEmail = oThis.SenderEmailAddress
        'hunt for folder, using FindFolder function below
        Set ff = FindFolder(fInbox, sEmail)
        End If
        'if folder exists, move email item
        If Not (ff Is Nothing) Then
        uDist.lAction.Caption = "Moving..."
        uDist.lName.Caption = oThis.SenderEmailAddress
        uDist.lName.Visible = True
        uDist.lTo.Visible = True
        uDist.lFolder.Caption = ff.Name
        uDist.lFolder.Visible = True
        oThis.Move ff
        uDist.lAction.Caption = "Searching..."
        End If
    End If
i = i - 1
'repeat until all inbox covered
Loop Until (i = 0)
uDist.lAction.Caption = "Done"
uDist.lAction.Visible = True
uDist.lAction.Visible = True

'display completion uDist for 3 seconds
i = Timer + 3
Loop Until Timer > i

End Sub

Function FindFolder(fCheck As Outlook.Folder, sEmail As String) As Outlook.Folder
'works with Distribute2Folders above
Dim ff As Outlook.Folder
Dim oItems As Items, oCheck As MailItem
Set FindFolder = Nothing
'loop through folders:
For Each ff In fCheck.Folders
Set oItems = ff.Items
'check for target email address in folder:
Set oCheck = oItems.Find("[SenderEmailAddress] = '" & sEmail & "'")
    If Not (oCheck Is Nothing) Then
    'if found, set this folder to the target folder
    Set FindFolder = ff
    Exit Function
    'if not found, keep searching in subfolders of subfolders:
    Set FindFolder = FindFolder(ff, sEmail)
        If Not (FindFolder Is Nothing) Then
        Exit Function
        End If
    End If

End Function

Open in new window


Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial