Moving ALL messages from ALL folders into one folders

[SiliciousG]

I have browsed, played and failed to create a macro that allows me to drill down into all my sub-folders in not only my main profile but also in Archived and other PST files.

I want to get all my 15-off Gb of email in one folder, run a few dup-removers and then sit down with a cup of coffee and structure all of them out into new folders.

I can get macros running that move all SELECTED emails to a folder, but i need this to be on loop for one folder to another and also for instance from a sub-folder in an old archive pst (opened in my profile) into the Inbox (to make it easy) of the main profile.

Please help! I used to have time to fiddle with this until i got it, now i cant anymore.

Rene

 

[Amanda Barron]

Hi, Rene

You can use the following macro to the task:

You can press "Alt + F11" keys to enter VBA editor window, and then copy the following macro to a new module:

Private Sub GetAllFolders()
    Dim objFolders As Outlook.Folders
    Dim objFolder As Outlook.Folder

    'Get all the folders in a specific PST file
    Set objFolders = Outlook.Application.Session.Folders("PST 1").Folders

    For Each objFolder In objFolders
        Call MoveEmails(objFolder)
    Next
End Sub

Private Sub MoveEmails(ByVal objFolder As Outlook.Folder)
    Dim objTargetFolder As Outlook.Folder
    Dim objSubFolder As Outlook.Folder
    Dim i As Long
    Dim objMail As Outlook.MailItem

    'Get the specific destination folder
    'You can change it as per your case
    Set objTargetFolder = Outlook.Application.Session.Folders("PST 2").Folders("New")

    If objTargetFolder Is Nothing Then
       Set objTargetFolder = Outlook.Application.Session.Folders("PST 2").Folders.Add("New")
    End If

    'Move each emails in the folder to the destination folder
    For i = objFolder.Items.Count To 1 Step -1
        If objFolder.Items.Item(i).Class = olMail Then
           Set objMail = objFolder.Items.Item(i)
           objMail.Move objTargetFolder
        End If
    Next i

    'Process the subfolders in the folder recursively
    If (objFolder.Folders.Count > 0) Then
       For Each objSubFolder In objFolder.Folders
           Call MoveEmails(objSubFolder)
       Next
    End If
End Sub

you can run the new macro by click the "Run" icon in the toolbar or press the "F5" key. At once, all the emails of all the folders in a specific folder will be moved to the predetermined folder in batches.

Hope that helps!

Good luck!

Amanda