Option Explicit

Sub MoveMessage()
Dim olMsg As MailItem
Dim olFolder As Folder
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    GetFolder olMsg, "Folder Name"
lbl_Exit:
    Set olMsg = Nothing
    Exit Sub
End Sub

Sub GetFolder(olItem As MailItem, strFolderName As String)
Dim olNS As NameSpace
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim StartFolder As Outlook.Folder
Dim SubFolder As Outlook.Folder
Dim bExists As Boolean
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    Set StartFolder = olNS.PickFolder
    cFolders.Add StartFolder
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        If UCase(olFolder.Name) = UCase(strFolderName) Then
            bExists = True
            Exit Do
        End If
        For Each SubFolder In olFolder.folders
            cFolders.Add SubFolder
        Next SubFolder
    Loop
    If Not bExists Then
        Set olFolder = StartFolder.folders.Add(strFolderName)
    End If
    olItem.Move olFolder
lbl_Exit:
    Set olNS = Nothing
    Set StartFolder = Nothing
    Set cFolders = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub