Move Emails To Specified Folder After Assigning Certain Category - Shared Mailbox

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!

Code:

---

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

---

In theory at least, and based on your code, the following should work, and certainly the folder is created as required, but the Move command is not working in my installation, which may be a local issue
Change 'Display Name of Shared Account' to the name of that account as appropriate. There is no need to give Item another variable name.

Code:

---

Option Explicit
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.items
Private WithEvents shInboxFld As Outlook.Folder
Private WithEvents shInboxItems As Outlook.items


Private Sub Application_Startup()
    Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
    Set xInboxItems = xInboxFld.items
    Set shInboxFld = Outlook.Application.Session.Accounts.Item("Display Name of Shared Account").DeliveryStore.GetDefaultFolder(olFolderInbox)
    Set shInboxItems = shInboxFld.items
End Sub


Private Sub xInboxItems_ItemChange(ByVal Item As Object)
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
        xFlag = False
        If Item.Categories <> "" Then
            Set xFlds = xInboxFld.folders
            If xFlds.Count <> 0 Then
                For Each xFld In xFlds
                    If xFld.Name = Item.Categories Then
                        xFlag = True
                        Exit For
                    End If
                Next
            End If
            If xFlag = False Then
                xInboxFld.folders.Add Item.Categories, olFolderInbox
            End If
            Set xTargetFld = xInboxFld.folders(Item.Categories)
            Item.Move xTargetFld
        End If
    End If
End Sub


Private Sub shInboxItems_ItemChange(ByVal Item As Object)
Dim shFlds As Outlook.folders
Dim shFld As Outlook.Folder
Dim shTargetFld As Outlook.Folder
Dim shFlag As Boolean
    On Error Resume Next
    If Item.Class = olMail Then
        shFlag = False
        If Item.Categories <> "" Then
            Set shFlds = shInboxFld.folders
            If shFlds.Count <> 0 Then
                For Each shFld In shFlds
                    If shFld.Name = Item.Categories Then
                        shFlag = True
                        Exit For
                    End If
                Next
            End If
            If shFlag = False Then
                shInboxFld.folders.Add Item.Categories, olFolderInbox
            End If
            Set shTargetFld = shInboxFld.folders(Item.Categories)
            Item.Move shTargetFld
        End If
    End If
End Sub

---