asked on

Need to find duplicate folders and move mails accordingly

Hi,

Need to find duplicate folders and move mails accordingly

Say i have 2 identical folders within a root folder like

Sharath
Sharath1

1 will be the increment for the identical folder.

If found 1 at the end of the folder name then check for similar folder name without one. if found move all mails from the 1 named folder to the identical named folder and then delete the empty folder.

Regards
Sharath

David Lee

Hi, Sharath.

Search where? All folders in all mailboxes and PST files? Also are you saying that the name match is only to occur if the second folder has a 1 on the end? For example, Sharath and Sharath1 would be considered a match but Sharath and Sharath2 would not. Is that correct?

bsharath

ASKER

Search just the subfolders that i select the root folder and run..
just the folders below the selected folder
Full exact name has to be matched and 1 alone. I havent seen any with 2 till now. So we shall take 1 into consideration and move mails from Sharath1 to Sharath and delete Sharath1
Find duplicates for all name matches. Folder names will have spaces....

Chris Bottomley

bsharath:

Does this requirement apply only to those folders directly below the selected folder ...

fred
doris
doris1
norman
doris

i.e. if Fred is the root folder selected then the function applies to:
fred\doris
fred\doris1
fred\norman

AND NOT

fred\norman\doris

Chris

bsharath

ASKER

It applies to just the Root folder

fred
doris
doris1
norman
doris
Only where no 1 shows as duplicate

Chris Bottomley

fred
doris
doris1
norman
doris1

Sorry still not clear, is folder fred\norman\doris1 in the above scenario excluded

Chris

Chris Bottomley

Assuming it is just the immediate sub folders then:

Chris

Sub Q25029903()
Dim myFolder As MAPIFolder
Dim itm As Object
Dim fldr As Object
Dim intFldr As Integer
        
    Set myFolder = Application.GetNamespace("mapi").PickFolder
    If Not myFolder Is Nothing Then
        For intFldr = myFolder.folders.count To 1 Step -1
            Set fldr = myFolder.folders(intFldr)
            If IsNumeric(Right(fldr.Name, 1)) Then
                If Not myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1)) Is Nothing Then
                    For Each itm In fldr.items
                        itm.Move myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1))
                    Next
                    fldr.Delete
                End If
            End If
        Next
    End If

End Sub

Open in new window

bsharath

ASKER

Chris its the immediate Sub folder.
Will it Copy emails and delete the duplicate folder also?

Chris Bottomley

The script above processes the folders immediately below the selected folder and moves all the items in a numbered suffix to the folder of the same name without a suffix and then deletes the suffixed folder.

IF there is no folder without the suffix then it does nothing.

Chris

Chris Bottomley

Stupid mistake therein! Please see correction

Chris

Sub Q25029903() 
Dim myFolder As MAPIFolder 
Dim intItem As integer 
Dim itm As Object 
Dim fldr As Object 
Dim intFldr As Integer 
         
    Set myFolder = Application.GetNamespace("mapi").PickFolder 
    If Not myFolder Is Nothing Then 
        For intFldr = myFolder.folders.count To 1 Step -1 
            Set fldr = myFolder.folders(intFldr) 
            If IsNumeric(Right(fldr.Name, 1)) Then 
                If Not myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1)) Is Nothing Then 
                    For intItem = fldr.items.count to 1 step -1
                        set itm = fldr.items(intItem)
                        itm.Move myFolder.folders(Left(fldr.Name, Len(fldr.Name) - 1)) 
                    Next 
                    fldr.Delete 
                End If 
            End If 
        Next 
    End If 
 
End Sub

Open in new window

bsharath

ASKER

Chris i get this

An Object failed could not be found

WHEN DEBUG GOES HERE'
If Not myFolder.Folders(Left(fldr.Name, Len(fldr.Name) - 1)) Is Nothing Then

ASKER CERTIFIED SOLUTION

Chris Bottomley

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

bsharath

ASKER

Thanks Chris works perfect

any help on this

https://www.experts-exchange.com/questions/25040527/Find-Outlook-folders-in-all-pst's-if-found-rename-them-as-per-the-txt-file.html