Outlook Macro to Create Folders Under PST for each unique contact and move emails

[pyrte]

Hi guys,

Its been a long time since I got here. I've been faced with a massive task at hand. I've been asked to clean up one of my IT directors emails in outlook.

It looks like he has a PST set up with just one folder. Now he requires me to create a folder in the PST for each contact available within the emails in the PST and then move the emails to respective folders.

Given, that he is an IT director he has a ton of emails and I cant imagine how I can do this manually.

I was hoping that anyone here might be able to help me with some macro that will do all of this automatically.

Appreciate all the help you all can offer.

Regards.

[gmayor]

The following will create a subfolder in the Inbox for every unique sender and move the corresponding items to that folder.
This could result in a huge number of folders - especially if there is a raft of single messages or spam in the inbox.
I strongly urge you to backup the PST file before you begin, so that when it all goes pear shaped you can get back to the start position and keep your job.


Sub CreateFolders()
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olNewFolders As folders
Dim olItems As Items
Dim olItem As MailItem
Dim strName As String
Dim i As Long
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox)
Set olNewFolders = olFolder.folders
Set olItems = olFolder.Items
On Error Resume Next
For i = olItems.Count To 1 Step -1
Set olItem = olItems(i)
strName = olItem.Sender
olNewFolders.Add strName, olFolderInbox
olItem.Move olFolder.folders(strName)
Next i
lbl_Exit:
Exit Sub
End Sub

[pyrte]

Thanks so much. I'm impressed, you got to get the code done so quick. You are awesome.

Below you mentioned "will create a subfolder in the Inbox for every unique sender". Right now all the emails are in a PST folder called "'Read"

I need to create folders within the PST for example

Sender A
Sender B
and so on.

Then get the emails from the Read folder to specific user folder.

Are we on the same page.



The following will create a subfolder in the Inbox for every unique sender and move the corresponding items to that folder.
This could result in a huge number of folders - especially if there is a raft of single messages or spam in the inbox.
I strongly urge you to backup the PST file before you begin, so that when it all goes pear shaped you can get back to the start position and keep your job.


Sub CreateFolders()
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olNewFolders As folders
Dim olItems As Items
Dim olItem As MailItem
Dim strName As String
Dim i As Long
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderInbox)
Set olNewFolders = olFolder.folders
Set olItems = olFolder.Items
On Error Resume Next
For i = olItems.Count To 1 Step -1
Set olItem = olItems(i)
strName = olItem.Sender
olNewFolders.Add strName, olFolderInbox
olItem.Move olFolder.folders(strName)
Next i
lbl_Exit:
Exit Sub
End Sub

[pyrte]

Also I think I can move all the emails from the PST folder to the Inbox. So if the macro can pick the emails from the Inbox and then sort them into respective folders it would be awesome.

[gmayor]

The macro works with the InBox as a base point, as that is where e-mails are usually delivered to.
If they are in another folder called "Read", then the following variation will allow you to pick the folder e.g. "Read" and the sub folders will be created wherever you set the value of olNewFolders - here it is a subfolder of the parent folder of "Read" so on the same level as "Read"

Sub CreateFolders()
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olNewFolders As folders
Dim olItems As Items
Dim olItem As MailItem
Dim strName As String
Dim i As Long
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
Set olNewFolders = olFolder.Parent.folders
Set olItems = olFolder.Items
On Error Resume Next
For i = olItems.Count To 1 Step -1
Set olItem = olItems(i)
strName = olItem.Sender
olNewFolders.Add strName, olFolderInbox
olItem.Move olNewFolders(strName)
Next i
lbl_Exit:
Exit Sub
End Sub

[pyrte]

This worked like a charm gmayor. You are like the Rockstar of outlook automation. I can't imagine the things I will be able to do if I have the skills that you have. You are awesome. Thanks you so much for getting this coded out for me. Appreciate it.


The macro works with the InBox as a base point, as that is where e-mails are usually delivered to.
If they are in another folder called "Read", then the following variation will allow you to pick the folder e.g. "Read" and the sub folders will be created wherever you set the value of olNewFolders - here it is a subfolder of the parent folder of "Read" so on the same level as "Read"

Sub CreateFolders()
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olNewFolders As folders
Dim olItems As Items
Dim olItem As MailItem
Dim strName As String
Dim i As Long
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
Set olNewFolders = olFolder.Parent.folders
Set olItems = olFolder.Items
On Error Resume Next
For i = olItems.Count To 1 Step -1
Set olItem = olItems(i)
strName = olItem.Sender
olNewFolders.Add strName, olFolderInbox
olItem.Move olNewFolders(strName)
Next i
lbl_Exit:
Exit Sub
End Sub

[gmayor]

Steady! :) Just don't ask me to put the files back if the boss doesn't like it. :doh:
Please mark the thread as answered.

[pyrte]

gmayor, You won't believe it. The macro worked flawless. Here is the catch. The boss being the director has something like thousand odd contacts and now is having a hard time finding the folder to look though past emails. I've marked this as answered. But It looks like I need to go around and figure out a way to move all the emails back to one folder. Sometimes people higher up never listen to folks that actually work on tasks. I am thinking if I can get a macro to move emails from all the folders to the inbox. Then I can move all the emails from the inbox to the PST manually. Lets see if I can find anything online.

[gmayor]

Frankly I am not surprised at all.

I cannot test the following, as I don't want to screw my Outlook folder structure, but I think the following should work.

Essentially it should put all the e-mails in any folder on the same level as the selected folder (which should be the folder you want to move the messages to) in the selected folder, obviously omitting the selected folder.

This will of course include any other folders at that level that the earlier macro didn't create, so you might want to add some conditions to leave those behind. The macro also deletes the empty folders, but you might want to do that manually later. Use at your own risk!


Sub RestoreMessages()
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olNewFolder As Folder
Dim olItems As Items
Dim i As Long
On Error Resume Next
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder 'The folder you want to move the messages to
For Each olNewFolder In olFolder.Parent.folders
If Not olNewFolder.Name = olFolder.Name Then
Set olItems = olNewFolder.Items
For i = olItems.Count To 1 Step -1
olItems(i).Move olFolder
Next i
End If
If olNewFolder.Items.Count = 0 Then olNewFolder.Delete
Next olNewFolder
lbl_Exit:
Set olFolder = Nothing
Set olNewFolder = Nothing
Set olNS = Nothing
Set olItems = Nothing
Exit Sub
End Sub

[pyrte]

You are a rockstar. I cannot imagine how you can come up with these awesome codes at such pace. I will possibly test this out at home on my personal laptop before trying anything with my Directors PC. You rock !!! Thanks so very much.


Frankly I am not surprised at all.

I cannot test the following, as I don't want to screw my Outlook folder structure, but I think the following should work.

Essentially it should put all the e-mails in any folder on the same level as the selected folder (which should be the folder you want to move the messages to) in the selected folder, obviously omitting the selected folder.

This will of course include any other folders at that level that the earlier macro didn't create, so you might want to add some conditions to leave those behind. The macro also deletes the empty folders, but you might want to do that manually later. Use at your own risk!


Sub RestoreMessages()
Dim olNS As NameSpace
Dim olFolder As Folder
Dim olNewFolder As Folder
Dim olItems As Items
Dim i As Long
On Error Resume Next
Set olNS = Application.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder 'The folder you want to move the messages to
For Each olNewFolder In olFolder.Parent.folders
If Not olNewFolder.Name = olFolder.Name Then
Set olItems = olNewFolder.Items
For i = olItems.Count To 1 Step -1
olItems(i).Move olFolder
Next i
End If
If olNewFolder.Items.Count = 0 Then olNewFolder.Delete
Next olNewFolder
lbl_Exit:
Set olFolder = Nothing
Set olNewFolder = Nothing
Set olNS = Nothing
Set olItems = Nothing
Exit Sub
End Sub