Macro for moving all emails from subfolders ( recursive )

Never wondered how I can get this emails sorted when all are spread in different folders ?

Well… I’ve got a very nice macro that I have found last week ;

In order this to work you will need to activate macro execution in your outlook

ALT +F11 ( Access Macro design )
Alt +F5 ( Execute Macro )


Dim objTargetFolder As Outlook.folder
Sub BatchMoveEmailsFromSubfoldersToAnotherFolder()
Dim objSourceFolder As Outlook.folder
Dim objFolder As Outlook.folder
'Get the source folder whose subfolders to be processed
Set objSourceFolder = Application.Session.PickFolder
If Not (objSourceFolder Is Nothing) And objSourceFolder.DefaultItemType = olMailItem Then
If objSourceFolder.folders.count > 0 Then
'Select a target folder
Set objTargetFolder = Application.Session.PickFolder
If Not (objTargetFolder Is Nothing) Then
For Each objFolder In objSourceFolder.folders
Call ProcessFolders(objFolder)
Next
MsgBox "Move Completed!", vbExclamation
End If
Else
MsgBox "No subfolders!", vbExclamation
End If
End If
End Sub
Sub ProcessFolders(ByVal objFolder As Outlook.folder)
Dim i As Long
Dim objSubfolder As Outlook.folder
For i = objFolder.Items.count To 1 Step -1
'Move emails to the target folder
If objFolder.Items(i).Class = olMail Then
objFolder.Items(i).Move objTargetFolder
End If
Next
'Process subfolders recursively
If objFolder.folders.count > 0 Then
For Each objSubfolder In objFolder.folders
Call ProcessFolders(objSubfolder)
Next
End If
End Sub