Replicate Search Folder Functionality / Move Categories to Subfolders

[gmayor]

What I suspect you are looking for is something like the following. The macro runs on the selected message and determines whether it has categories. If it does it moves a copy of the message to a folder bearing the category name that is a subfolder of Inbox. If the folder doesn't exist it is created. If there is no category it prompts for one then moves the message to the category named folder (or creates that folder, if it doesn't exist). The original message is then deleted.

Sub MoveMessageToCategoryFolder()
'Graham Mayor - https://www.gmayor.com - Last updated - 06 Aug 2020
Dim olMsg As Object, objCopy As Object
Dim vCategory As Variant
Dim strFolder As String
Dim olFolder As Folder, olSubFolder As Folder
Dim i As Integer
Dim bFound As Boolean

    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olMsg = ActiveInspector.currentItem
        Case olExplorer
            Set olMsg = Application.ActiveExplorer.Selection.Item(1)
    End Select

GetCategories:
    If TypeName(olMsg) = "MailItem" Then
        Set olFolder = Session.GetDefaultFolder(olFolderInbox)
        If olMsg.Categories <> "" Then
            vCategory = Split(olMsg.Categories, ",")
            For i = 0 To UBound(vCategory)
                bFound = False
                strFolder = Trim(vCategory(i))
                For Each olSubFolder In olFolder.folders
                    If olSubFolder.Name = strFolder Then
                        Set objCopy = olMsg.Copy
                        objCopy.Move olSubFolder
                        bFound = True
                        Exit For
                    End If
                Next olSubFolder
                If Not bFound Then
                    Set olSubFolder = olFolder.folders.Add(strFolder)
                    Set objCopy = olMsg.Copy
                    objCopy.Move olSubFolder
                End If
            Next i
        Else
            olMsg.ShowCategoriesDialog
            GoTo GetCategories
        End If
        olMsg.Delete
    End If
lbl_Exit:
    Exit Sub
End Sub