Many organizations use shared Exchange mailboxes for support and general information email addresses and assign the responsibility to answer the inquiries to a small group of users. To help even the workload, some managers want to assign the messages to users as they arrive, round-robin style, so each user gets the same number of messages.

It's actually fairly easy to do: count the messages and use Select Case to assign a message to a person.

In these examples, I'm using an ItemAdd macro because it can watch any folder in your profile for new messages, whereas a rule only watches your account's Inbox. Outlook needs to be open to use a macro and if you are moving messages to folders in other mailboxes, the mailboxes need to be in your profile (as a shared mailbox is fine). Because the Inbox is not the default Inbox in your profile, you'll need to use the GetFolderPath macro at the end of this page.

These macros start when Outlook starts; to kickstart the macros during testing, click in the Application_Startup macro and click Run.

To watch a folder in the default mailbox in a profile, use the following line in the Application Startup macro.
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items

Step 1

At the top of ThisOutlookSession, add this code and add the GetFolderPath function (found at the end of this article) to a new Module. Note: if you are watching for new messages in your default mailbox and are not moving the messages to folders in another mailbox or data file, you don't need the GetFolderPath function.

Dim i As Long
Private WithEvents olInboxItems As Items
 
Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session
  Set olInboxItems = GetFolderPath("Shared mailbox name\Inbox").Items
Set objNS = Nothing
End Sub

Step 2

Next, copy one of the ItemAdd macros below and paste it under the End Sub line in the Application_Startup macro.

Assign Categories | Move Messages to Folders
Move Messages to Other Mailboxes | Forward Messages

Assign Categories "Round Robin" style

Use the name of the mailbox as it appears in your folder list.

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
    Dim strCat As String
    
    If Item.Class = olMail Then
     
    Select Case i
     Case 0
          strCat = "Case 0"
     Case 1
          strCat = "Case 1"
     Case 2
          strCat = "Case 2"
     Case 3
          strCat = "Case 3"
     Case 4
          strCat = "Case 4"
    End Select
        
    Item.categories = strCat
            Item.Save
        Err.Clear
     End If
     i = i + 1
     Debug.Print i
     If i = 5 Then i = 0
 End Sub

Move Messages to Folders

In this example, I'm moving messages to a folder in the mailbox that is under the Inbox. (The messages in this screenshot were assigned the Case 0 category using the previous macro.)

If the folder is at the same level as the Inbox, use this line instead:
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders(moveFolder)

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

    Dim objDestFolder As Outlook.MAPIFolder
    Dim moveFolder As String
    
    If Item.Class = olMail Then
     
    Select Case i
     Case 0
          moveFolder = "Folder01"
     Case 1
          moveFolder = "Folder05"
     Case 2
          moveFolder = "Folder10"
     Case 3
          moveFolder = "Folder12"
     Case 4
          moveFolder = "Folder14"
    End Select
    
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Folders(moveFolder)
  Item.Move objDestFolder
        End If
        
        Err.Clear
          
     i = i + 1
     Debug.Print i
     If i = 5 Then i = 0
 Set objDestFolder = Nothing
 End Sub

Move messages based on sender name

The modification is in response to the question in this Microsoft Community thread, Microsoft Community thread, where the messages are assigned by the sender's name.

We need to get the first letter of the sender's name. The select case statements check to see which case is true and moves the message to a folder. The Case Else handles all messages that do not match the other case statements.

I'm using UCase function to force capitalize the letters, otherwise, someone with a lowercase display name would end up in the Else folder. If you prefer, you can force the sender names to lower case using Left(LCase(Item.SenderName), 1), but must also enter the letters in each case statement in lower case.

Private WithEvents olInboxItems As Items
 
Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session
  'Set olInboxItems = GetFolderPath("Shared mailbox name\Inbox").Items
  Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
Set objNS = Nothing
End Sub

Sub olInboxItems_ItemAdd(ByVal Item As Object)

    Dim objDestFolder As Outlook.MAPIFolder
    Dim moveFolder As String
    
   If Item.Class = olMail Then
    
     Debug.Print Item.SenderName, Left(Item.SenderName, 1)
     
    Select Case Left(UCase(Item.SenderName), 1)
    
     Case "A", "B", "C"
          moveFolder = "Folder01"
     Case "D", "E", "F"
          moveFolder = "Folder02"
     Case "G", "H", "I"
          moveFolder = "Folder03"
     Case Else ' letters not listed above
          moveFolder = "Folder04"
     
    End Select
    
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Folders(moveFolder)
  Item.Move objDestFolder
        End If
        
        Err.Clear
           
Set objDestFolder = Nothing
 End Sub

Move Messages to Other Mailboxes

In this example, I'm moving messages to each person's Inbox. To do this, I need the mailboxes in my profile as secondary mailboxes.

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

    Dim objDestFolder As Outlook.MAPIFolder
    Dim moveFolder As String
    
    If Item.Class = olMail Then
     
    Select Case i
     Case 0
          moveFolder = "Mary Contrary\Inbox"
     Case 1
          moveFolder = "Diane Poremsky\Inbox"
     Case 2
          moveFolder = "John Smith\Inbox"
     Case 3
          moveFolder = "Mark Jackson\Inbox"
     Case 4
          moveFolder = "Sue Ellen\Inbox"
    End Select

Set objDestFolder = GetFolderPath(moveFolder)
   Item.Move objDestFolder
        End If

        Err.Clear
          
     i = i + 1
     Debug.Print i
     If i = 5 Then i = 0
 Set objDestFolder = Nothing
 End Sub

Forward Messages

If you prefer to forward messages, you'll use this code. The address in the sendTo variable can either be the users Exchange alias or their SMTP email address. Change oForward.Display to oForward.Send to send the messages automatically.

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)

    Dim sendTo As String
    Dim oForward As MailItem
    Dim recip As Recipient
    If Item.Class = olMail Then
     
    Select Case i
     Case 0
          sendTo = "billys"
     Case 1
          sendTo = "johnj"
     Case 2
          sendTo = "dianep"
     Case 3
          sendTo = "maryc"
     Case 4
          sendTo = "henryp@mydomain.com"
    End Select
    
    Set oForward = Item.Forward
    Set recip = oForward.recipients.Add(sendTo)
        recip.Resolve
        oForward.Display 'send

        End If
        
        Err.Clear
          
     i = i + 1
     Debug.Print i
     If i = 5 Then i = 0

  Set recip = nothing
 End Sub

GetFolderPath Function

You need to use this function if the mailbox you are watching or that you are moving messages into is not the default mailbox in the profile.

' Use the GetFolderPath function to find a folder in non-default mailboxes
Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder
    Dim oFolder As Outlook.folder
    Dim FoldersArray As Variant
    Dim i As Integer
         
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function
         
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

How to use these Macros

First: You will need macro security set to low during testing.

To check your macro security in Outlook 2010 or 2013, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, it’s at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To use the macro code in ThisOutlookSession:

1. Expand Project1 and double click on ThisOutlookSession.
2. Copy then paste the macro into ThisOutlookSession. (Click within the code, Select All using Ctrl+A, Ctrl+C to copy, Ctrl+V to paste.)
3. Right-click on Project1 and choose New > Module
4. Paste GetFolderPath in this Module

More information as well as screenshots are at How to use the VBA Editor