Macro to bulk create Outlook rules from CSV file

Here is a macro that loops through a list in Excel to create rules in an Outlook shared mailbox (not exactly the same for a private mailbox). User 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

Remember to add references to Excel when running in Outlook.

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 = "email address removed for privacy reasons" 'Your shared mailbox name
    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
                    
                    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