I JUST wrote code for this. My macro searches emails for a specific string and then takes everything after that and creates a folder using that name. You'll need a few functions to:
1) Check to see if the folder already exists
2) Create it if it doesn't
3) Move the MailItem to the new folder
4) Call those functions
NOTE: Much of this is hard-coded and could be changed to take user input if desired. Also, it will not work for sub-folders (you'll have to customize that).
1) Check for folder:
Function CheckForFolder(strFolder As String) As Boolean
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0
If Not FolderToCheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
2) Create:
Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
3) Search and move:
Function SearchAndMove(lookFor As String)
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Dim myItem As Object
Dim MyFolder As Outlook.MAPIFolder
Dim lookIn As String
Dim newName As String
Dim location As Integer
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
For Each myItem In olInbox.Items
lookIn = myItem.Subject
If InStr(lookIn, lookFor) Then
location = InStr(lookIn, lookFor)
newName = Mid(lookIn, location)
If CheckForFolder(newName) = False Then
Set MyFolder = CreateSubFolder(newName)
myItem.Move MyFolder
Else
Set MyFolder = olInbox.Folders(newName)
myItem.Move MyFolder
End If
End If
Next myItem
End Function
4) call function:
Sub myMacro()
Dim str as String
str = "Thing to look for in the subjectline"
SearchAndMove (str)
End Sub
