Hi @AlexeyPA ,
Here is a macro that I think does what you want - it loops through a list in Excel to create rules in an Outlook shared mailbox (not exactly the same for a private mailbox). You will need to write the rules that route the emails to the correct folder - the MS documentation is here: https://learn.microsoft.com/en-us/office/vba/api/outlook.rules.create
If running in Outlook, remember to add reference to Excel. If running in Excel, remember to add reference to Outlook.
Hope it helps!
Sub CreateRules_SharedMailbox_1()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNamespace As Outlook.NameSpace
Set olNamespace = olApp.GetNamespace("MAPI")
Const sharedMailboxName As String = "******@xyz.zz" 'Your shared mailbox address
Const olFolderInbox As Integer = 6
Dim olRecipient As Outlook.Recipient
Set olRecipient = olNamespace.CreateRecipient(sharedMailboxName)
olRecipient.Resolve
Dim olFolder As Outlook.Folder
If olRecipient.Resolved Then
Set olFolder = olNamespace.GetSharedDefaultFolder(olRecipient, olFolderInbox)
Dim colRules As Outlook.Rules
Dim i As Long
For i = 1 To Session.Stores.Count
Debug.Print Session.Stores(i)
If Session.Stores(i).DisplayName = sharedMailboxName Then
Set colRules = olFolder.Store.GetRules()
Dim xlApp As Excel.Application
Set xlApp = CreateObject("Excel.Application")
Dim wb As Excel.Workbook
Set wb = xlApp.Workbooks.Open("C:\Users\xyz\YourExcel.xlsx") 'URL and filename for your Excel
Dim ws As Excel.Worksheet
Set ws = wb.Sheets("Test") 'Sheet name for your list
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(-4162).Row
Dim iRow As Long
For iRow = 2 To lastRow '2 to exclude header row
Dim trigger As String
Dim fldPath As String
trigger = ws.Cells(iRow, 1).Value 'Column A contains the trigger values
fldPath = ws.Cells(iRow, 2).Value 'Column B contains the fldPath values
'Create a new rule
Dim oRule As Outlook.Rule
Set oRule = colRules.Create(trigger, olRuleReceive)
'Set your rule conditions here
'See MS documentation
Dim oMoveTarget As Outlook.Folder
Set oMoveTarget = olFolder.Folders("Test")
Next iRow
wb.Close False
xlApp.Quit
colRules.Save
Exit For
End If
Next
End Sub