Macro to Sort Completed Emails

[jakebailey]

I'm looking for some direction with sorting emails. I have 50 customers that I receive email from daily. Once I am done with the email and it no longer needs any followup I move it to a 'Customers' folder. Within the 'Customers' folder I have sub-folders with each company name. In an effort to save time cleaning my Inbox I would like to have a macro that automatically moves the email from the 'Customers' folder to it's respective company folder based on the domain name '@companyname.com'. I've done searches online as well as this forum but haven't been able to get the right information to get me started.

I appreciate any suggestions or directions that you may have.

Thanks,
Jake

[JP2112]

If I understand you correctly, you want to search the sender email address and then move the email to the matching Inbox\Customers\customer name folder?

[jakebailey]

That is correct. However I only want this done once I have moved the email from my Inbox to the Inbox\Customers folder. My initial thought was I would create 'E-mail Rules' but only have them work within the Customers folder and not the Inbox. Like many other people I treat my Inbox like a To-Do List so until I'm done with the task it remains in my Inbox. Once I'm done I just want to drag it over to one folder and then have the Macro automatically sort it into the appropriate sub-folder.

[JP2112]

I would start with the code found here:

http://www.codeforexcelandoutlook.com/outlook-vba/stock-event-code/

But instead of

Set Items = objNS.GetDefaultFolder(olFolderInbox).Items

use

Set Items = objNS.GetDefaultFolder(olFolderInbox).Folders("Customers").Items

That will set a watch on the Customers subfolder, so whenever an email is dropped there you can take action on it. For example,

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Folders("Customers").Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

On Error Goto ErrorHandler

Dim Msg As Outlook.MailItem

If TypeName(item) = "MailItem" Then
Set Msg = item

Msg.Move Session.GetDefaultFolder(olFolderInbox).Folders("Customers").Folders(Msg.SenderEmailAddress)

End If

ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub

Of course, you would need to parse the sender email address, and the subfolder would need to already exist.