Move Email To Folder

This is easily done using the script below. Follow these instructions to set up and use it.

1. Start Outlook
2. Click Tools->Macro->Visual Basic Editor
3. If not already expanded, expand Modules and click on Module1
4. Copy the code and paste it into the right-hand pane of the VB Editor window
5. Edit the code as needed. I placed a comment line immediately before each line that needs editing
6. Click the diskette icon on the toolbar to save the changes
7. Close the VB Editor
8. Click Tools->Macro->Security
9. Set the Security Level to Medium
10. Close Outlook
11. Start Outlook
12. Create a rule that fires when new messages arrive. Set that rule to run the script.

Sub FileBySender(olkMessage As MailItem)
Dim olkRootFolder As Outlook.MAPIFolder, _
olkSenderFolder As Outlook.MAPIFolder
'Change the folder path on the following line as needed
Set olkRootFolder = OpenMAPIFolder("\Mailbox - Doe, John")
On Error Resume Next
Set olkSenderFolder = olkRootFolder.Folders.Item(olkMessage.SenderName)
On Error GoTo 0
If TypeName(olkSenderFolder) = "Nothing" Then
Set olkSenderFolder = olkRootFolder.Folders.Add(olkMessage.SenderName)
End If
olkMessage.Move olkSenderFolder
Set olkSenderFolder = Nothing
Set olkRootFolder = Nothing
End Sub

'Credit where credit is due.
'The code below is not mine. I found it somewhere on the internet but do
'not remember where or who the author is. The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
Dim app, ns, flr, szDir, i
Set flr = Nothing
Set app = CreateObject("Outlook.Application")
If Left(szPath, Len("\")) = "\" Then
szPath = Mid(szPath, Len("\") + 1)
Else
Set flr = app.ActiveExplorer.CurrentFolder
End If
While szPath <> ""
i = InStr(szPath, "\")
If i Then
szDir = Left(szPath, i - 1)
szPath = Mid(szPath, i + Len("\"))
Else
szDir = szPath
szPath = ""
End If
If IsNothing(flr) Then
Set ns = app.GetNamespace("MAPI")
Set flr = ns.Folders(szDir)
Else
Set flr = flr.Folders(szDir)
End If
Wend
Set OpenMAPIFolder = flr
End Function

Function IsNothing(obj)
If TypeName(obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function

Please post back if you have any more problems or questions.
If this information is useful, please mark as helpful. Thanks.