Hello,

I'm very new to outlook and VBA. I've found the code below which is working exactly how I want it - assign a category, the email gets moved real time to the associated folder within my inbox - if the folder does not exist, it makes one.

I want this code to function properly on a shared mailbox I am a part of as well - it is not part of my Microsoft account but I have full access to the mailbox. I need the same functionality - while in the inbox, assign a category and have it move to the corresponding subfolder within the shared mailbox's inbox.

Any help would be appreciated - as I said I'm very new to VBA but I can try to answer any questions!


PrivateWithEventsxInboxFld AsOutlook.FolderPrivate WithEvents xInboxItems As Outlook.Items

Private Sub Application_Startup()
    Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
    Set xInboxItems = xInboxFld.Items
End Sub

Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
    Set xMailItem = Item
    xFlag = False
    If xMailItem.Categories <> "" Then
        Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
        If xFlds.Count <> 0 Then
            For Each xFld In xFlds
                If xFld.Name = xMailItem.Categories Then
                    xFlag = True
                End If
            Next
        End If
        If xFlag = False Then
            Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
        End If
        Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
        xMailItem.Move xTargetFld
    End If
End If
EndSub