VBA to create a rule for each unique sender in a folder

My company run Exchange server 2016 and Outlook 2016
Some users have have many (hunderds) of folder in their inbox keeped updated manually. I want to automatically create rules to keep their structure updated.

Let me expain with an exemple:

(inbox) exemple@mycompany.com
- Folder Clients
> Sub folder A
>> mail from exemple1@a.com
>> mail from exemple2@a.com
>> mail from exemple1@a.com
> Sub folder B
>> mail from exemple1@b.com
> Sub foldder C
- Folder suppliers

Selecting a folder I want to automatically create rules for all subfolders. In this exemple selecting the root I want to create those rules:
1) move mail from exemple1@a.com or exemple2@a.com to folder clients/A
2) move mail from exemple1@b.com to folder clients/B
Giovanni AAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

VBA is not the right way to implement such rules.

The rules should be on the server side,and I think the right tool for this implementation is Powershell as described in the following atricle:

Managing users’ Outlook rules from Exchange Management Shell (with PowerShell)
Giovanni ACommented:
Probably I did not explain well my intent.

I have to create a ton of rules for any user. This will take too mouch time both by gui and by powershell. Since All the rule I want to create have the same logic I want to automate their creation.

Theorically I also can create a script that generates the powershell command and then execute them by powershell. I think is more difficult but is also ok if you can help me in that.

Let me expain with an exemple:

inbox exemple@mycompany.com
- Clients
> A
>> mail from exemple1@a.com
>> mail from exemple2@a.com
>> mail from exemple1@a.com
> B
>> mail from exemple1@b.com
> C
- suppliers

I want to automatically create those rules:
1) move mail from exemple1@a.com or exemple2@a.com to folder clients/A
2) move mail from exemple1@b.com to folder clients/B
Giovanni ACommented:
Please also consider that with outlook 2016 and exchange 2016 I expect client side rules compatible with exchange server (like the described ones)  to automatically move to exchange. This works in my tests
Giovanni AAuthor Commented:
I updated the request. I hope it is more easy to understand what I need
Neil FlemingConsultant and developerCommented:
Hi Giovanni: try this:

There are two procedures below. Basically the first runs through your inbox and calls the second, which looks in subfolders for instances of a username. If it finds a target folder, it moves all emails from that person to the subfolder found.

You could also create a userform that pops up and tracks what is going on. But this wokrs fine without such a form.

You just have to call "Distribute2Folders". That uses the second procedure "FindFolder" to find your folders.

Sub Distribute2Folders()
Dim ff As Outlook.Folder, fInbox As Outlook.Folder
Dim oItems As Items, oThis As MailItem
Dim i As Long
Dim sEmail As String

'get inbox
Set fInbox = Session.GetDefaultFolder(olFolderInbox)
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
        Debug.Print "Moving: " & oThis.SenderEmailAddress
        oThis.Move ff
        End If
    End If
i = i - 1
'repeat until all inbox covered
Loop Until (i = 0)
End Sub

Function FindFolder(fCheck As Outlook.Folder, sEmail As String) As Outlook.Folder
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


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today

From novice to tech pro — start learning today.