Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace
  Set Ns = Application.GetNamespace("MAPI")
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Mail = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
    End If
  End If
End Sub

'Sample #1
Private Sub Mail_PropertyChange(ByVal Name As String)
  Dim Ns As Outlook.NameSpace
  Dim SubfolderName As String
  Dim Inbox As Outlook.MAPIFolder
  Dim Subfolder As Outlook.MAPIFolder
  Dim i&
  Dim Cats As String
  Dim arrCats() As String
  Dim FindCategory As String

  ' Customize
  FindCategory = " (Actionlist)"
  SubfolderName = "test"

  Set Ns = Application.GetNamespace("MAPI")
  Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
  Set Subfolder = Inbox.Folders(SubfolderName)
  If Subfolder.EntryID = Mail.Parent.EntryID Then
    Exit Sub
  End If
  FindCategory = LCase$(FindCategory)

  If Name = "Categories" Then
    Cats = Mail.Categories
    If Len(Cats) = 0 Then Exit Sub
    Cats = Replace(Cats, ",", ";")
    arrCats = Split(Cats, ";")
    For i = 0 To UBound(arrCats)
      Cats = LCase$(arrCats(i))
      If Cats = FindCategory Then
        Mail.Move Subfolder
        Set Mail = Nothing
        Exit For
      End If
    Next
  End If
End Sub

'Sample #2
Private Sub Mail_PropertyChange(ByVal Name As String)
  Dim Ns As Outlook.NameSpace
  Dim Inbox As Outlook.MAPIFolder
  Dim Subfolder As Outlook.MAPIFolder
  Dim SubfolderName As String

  If Name = "Categories" Then
    Set Ns = Application.GetNamespace("MAPI")
    Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
    SubfolderName = Mail.Categories
    If Len(SubfolderName) = 0 Then Exit Sub
    Set Subfolder = Inbox.Folders(SubfolderName)
    If Subfolder.EntryID <> Mail.Parent.EntryID Then
      Mail.Move Subfolder
      Set Mail = Nothing
    End If
  End If
End Sub