<div>
Script code examples to build from here: 
<a href="http://www.outlookcode.com" rel="ugc">http://www.outlookcode.com</a> 
<a href="http://www.slovaktech.com/code_samples.htm" rel="ugc">http://www.slovaktech.com/code_samples.htm</a> 

</div>

<div>
To confirm: 
 
If any two folders have the same name, (whatever the folder path) then the contents are all moved to a specific folder? 
 
Assuming yes, is that specific folder one of the duplicates or some specific path you want to identify? 
 
Chris
</div>

<div>
I want to move all that may be duplicate to the Mailbox\inbox. So later i can verify them and move the mails mamually into one and delete the empty folders...
</div>

<div>
I meant move the duplicate folders along with mails to &quot;mailbox\inbox&quot; 

</div>

<div>
So if for example the found duplicates are: 
 
\\Latest Mails\Inbox\JtoO\Microsoft 
\\Jan2009\Inbox\Vendors\Microsoft 
 
How do you want them moved? 
 
\\Personal Folders\Inbox\Microsoft-2 
\\Personal Folders\Inbox\Microsoft-1 
 
OR all contents into: 
 
\\Personal Folders\Inbox\Microsoft 
 
Chris
</div>

<div>
I will need them as this 
 
\\Mailbox - Sharath\Inbox\Microsoft-2 
\\Mailbox - Sharath\Inbox\Microsoft-1 

</div>

<div>
OKay 
 
I think I have a solution as follows: 
 
Run sub collateDupeFolders and any duplicated foldernames with contents are collated under the specified inbox. 
 
Chris 

<pre><code class="code-100 nolinks" id="code-286258">Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each Fldr In Application.GetNamespace(&quot;mapi&quot;).folders
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
 For Each itm In masterList.Keys
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 Next
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderIndex = 0 To UBound(fldrs)
 strFolder = fldrs(folderIndex)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
Thanks Chris just started the macro and i am sure its going to take a while for the results 
Can you have a look at this 
<a href="https://www.experts-exchange.com/questions/24264376/Delete-all-Identical-mails-in-a-folder-Compare-the-Subject-and-then-the-body-data-of-the-mail-and-delete-all-except-1.html" rel="ugc">https://www.experts-exchange.com/questions/24264376/Delete-all-Identical-mails-in-a-folder-Compare-the-Subject-and-then-the-body-data-of-the-mail-and-delete-all-except-1.html</a>
</div>

<div>
Chris the script has been running for a while. Does it search for a duplicate folder in all the pst's? 
 

</div>

<div>
Yup, I made a few assumptions .. 
 
1. Search all PST's 
2. Ignore standard folders 
3. I haven't excluded public folders - more by omission thatn intent though 
 
Chris
</div>

<div>
Thanks i think i need to leave it for a long time to scan and diagnose all the folders... Shall get back when its done....
</div>

<div>
Modified to exclude public folder ... should that be a requirement! 
 
Chris 

<pre><code class="code-100 nolinks" id="code-286291">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
 For Each itm In masterList.Keys
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 Next
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderIndex = 0 To UBound(fldrs)
 strFolder = fldrs(folderIndex)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
I get run time error 9 
 
When debug it goes here 
&nbsp; &nbsp; For Each itm In masterList.Keys 
I think the time was taken on the public folders. thats for the exclusion
</div>

<div>
Is the name of the mailbox i am going wrong. 
 
i right click on the Mailbox and go to properties and thats the name i am mentioning 

</div>

<div>
CAn you do me a favour and try with the modified post? 
 
Chris
</div>

<div>
Yes i got the above error on the last code. In the first code it was going on running and did not end...
</div>

<div>
Still works fine on my tests. &nbsp;I have modified to append an output to the immediate window ... can you examine and provide any data therefrom at the time of failure? 
 
Chris 

<pre><code class="code-100 nolinks" id="code-286343">Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
 For Each itm In masterList.Keys
 Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 Next
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderIndex = 0 To UBound(fldrs)
 strFolder = fldrs(folderIndex)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
I get this in the immediate window and get the error 
 
1 &nbsp; \\Mailbox - Sharath 
2 &nbsp; \\Mailbox - Sharath\Deleted Items 
3 &nbsp; \\Mailbox - Sharath\Inbox 
4 &nbsp; \\Mailbox - Sharath\Inbox\Dupes 
5 &nbsp; \\Mailbox - Sharath\Inbox\Sophos old 
6 &nbsp; \\Mailbox - Sharath\Inbox\Sophos old\Backup Sophos 
7 &nbsp; \\Mailbox - Sharath\Inbox\Sophos old\27th 
8 &nbsp; \\Mailbox - Sharath\Outbox 
9 &nbsp; \\Mailbox - Sharath\Sent Items 
10 &nbsp;\\Mailbox - Sharath\Calendar 
11 &nbsp;\\Mailbox - Sharath\Contacts 
12 &nbsp;\\Mailbox - Sharath\Drafts 
13 &nbsp;\\Mailbox - Sharath\Journal 
14 &nbsp;\\Mailbox - Sharath\Junk E-mail 
15 &nbsp;\\Mailbox - Sharath\Notes 
16 &nbsp;\\Mailbox - Sharath\Notes\Linked Notes 
17 &nbsp;\\Mailbox - Sharath\RSS Feeds 
18 &nbsp;\\Mailbox - Sharath\RSS Feeds\hu.com 
19 &nbsp;\\Mailbox - Sharath\RSS Feeds\sha(1) 
20 &nbsp;\\Mailbox - Sharath\Sophos Mails 
21 &nbsp;\\Mailbox - Sharath\Sync Issues1 
22 &nbsp;\\Mailbox - Sharath\Sync Issues1\Conflicts 
23 &nbsp;\\Mailbox - Sharath\Sync Issues1\Local Failures 
24 &nbsp;\\Mailbox - Sharath\Sync Issues1\Server Failures 
25 &nbsp;\\Mailbox - Sharath\Tasks
</div>

<div>
Okay another hack to see how many folders are stored and their names ... to see what might come after tasks. 
 
Chris 

<pre><code class="code-100 nolinks" id="code-286349">Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
 For itm = 1 To masterList.count
 Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 Next
 For Each itm In masterList.Keys
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 Next
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderIndex = 0 To UBound(fldrs)
 strFolder = fldrs(folderIndex)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
Still just get the same identical 25 and the error 
</div>

<div>
Once again it is unfortunately a case of suck it and see where it fails ... it works fine for me, and so I must be missing something and need a clue as to what! 
 
Does the error occur at the same point ... i.e. break point? 
 
Chris
</div>

<div>
Yes the same point... Can i have the destination selecatable. Just to make sure that i am not mentioning the wrong path ? 
 
 

</div>

<div>
So it's not the data that failing per se .. I think, i'll look into a different structure in the morning and then see how that works. 
 
Chris
</div>

<div>
Restructured the main loop to reflect the test loop, still the outputs on screen so any better ... and if so i'll tidy up re outputs afterwards 
 
Chris 

<pre><code class="code-100 nolinks" id="code-286527">Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
Dim intItem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
 For itm = 1 To masterList.count
 Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 Next
 Stop
 For intItem = 1 To masterList.count
 itm = intItem
 Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 Next
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderIndex = 0 To UBound(fldrs)
 strFolder = fldrs(folderIndex)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
 
 
 
 
Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Outlook.mailitem
Dim strFilter As String
 
 Set olkApp = Outlook.Application
 Set objns = olkApp.GetNamespace(&quot;MAPI&quot;)
 Set myfolder = olkApp.ActiveExplorer.CurrentFolder
 On Error GoTo skipthisone
 For mailCounter = myfolder.items.count To 1 Step -1
 Set mai = myfolder.items(mailCounter)
 strFilter = &quot;[Subject] = &quot; &amp; append_quotes(mai.subject)
 Set olkmailitems = myfolder.items.Restrict(strFilter)
 For bodyCount = olkmailitems.count - 1 To 1 Step -1
 If mai.body = olkmailitems(bodyCount).body Then
 olkmailitems(bodyCount).Delete
 End If
 Next
skipthisone:
 Next
 
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
 append_quotes = Chr(34) &amp; CStr(objString) &amp; Chr(34)
End Function
</code></pre>
</div>

<div>
When run it just comes out after the 25 collection to 
&nbsp; &nbsp; Stop 

</div>

<div>
Overlooked that line 
 
Chris 

<pre><code class="code-100 nolinks" id="code-286558">Option Explicit
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderIndex As Integer
Dim intItem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
 For itm = 1 To masterList.count
 Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 Next
 'Stop
 For intItem = 1 To masterList.count
 itm = intItem
 Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 Next
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderIndex = 0 To UBound(fldrs)
 strFolder = fldrs(folderIndex)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
 
 
 
 
Sub deleteExcessEmails()
Dim olkApp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim olkmailitems As Outlook.items
Dim mailCounter As Integer
Dim bodyCount As Integer
Dim mai As Outlook.mailitem
Dim strFilter As String
 
 Set olkApp = Outlook.Application
 Set objns = olkApp.GetNamespace(&quot;MAPI&quot;)
 Set myfolder = olkApp.ActiveExplorer.CurrentFolder
 On Error GoTo skipthisone
 For mailCounter = myfolder.items.count To 1 Step -1
 Set mai = myfolder.items(mailCounter)
 strFilter = &quot;[Subject] = &quot; &amp; append_quotes(mai.subject)
 Set olkmailitems = myfolder.items.Restrict(strFilter)
 For bodyCount = olkmailitems.count - 1 To 1 Step -1
 If mai.body = olkmailitems(bodyCount).body Then
 olkmailitems(bodyCount).Delete
 End If
 Next
skipthisone:
 Next
 
Set olkmailitems = Nothing
Set objns = Nothing
Set olkApp = Nothing
Set myfolder = Nothing
 
End Sub
 
Function append_quotes(objString As String) As String
 append_quotes = Chr(34) &amp; CStr(objString) &amp; Chr(34)
End Function
</code></pre>
</div>

<div>
Chris still gets stuck in the same 25 and get the error 91 

</div>

<div>
You are going to need to do some invest ... 
 
I assume there are multiple PST's but we only seem to be processing the first one. &nbsp;How many folders are there in the postbox ... i.e. does 25 look correct for all folders and subfolders? 
 
The fact that the error is now 91 means something has changed for the better. &nbsp;Is it still breaking on the same line? 
 
Chris
</div>

<div>
Yes... 
 
i think just the mailbox is being processed and not any pst's 

</div>

<div>
Chris what i did is create a duplicate folder in the mailbox and checked it does work. 
I get the error on this line 
&nbsp; &nbsp; For itm = 1 To masterList.Count 
So one thing we can be sure is the code works but just works on the mailbox. And not the other 5 pst's 

</div>

<div>
Only running on the mailbox because of the error, the loop on storesitem is a proven construct on previous posts with you so once we resolve the failure we should be okay for all pst's. 
 
When it breaks on: 
For itm = 1 To masterList.Count 
 
Can you identify the values for the data in the immediate window, (ctrl + G) ... one I assume will bring an error up. 
 
?itm 
?masterlist.count 
 
Chris
</div>

<div>
I get this error after 25 
--------------------------- 
Microsoft Visual Basic 
--------------------------- 
Run-time error '91': 
 
Object variable or With block variable not set 
--------------------------- 
OK &nbsp; Help &nbsp; 
--------------------------- 
 
When i take mouse over itm 
i get 
itm=Empty
</div>

<div>
masterlist.count value? 
 
Chris
</div>

<div>
I get this 
 
--------------------------- 
Microsoft Visual Basic 
--------------------------- 
Run-time error '424': 
 
Object required 
--------------------------- 
OK &nbsp; Help &nbsp; 
--------------------------- 
When i put 
?masterlist.count 
in the Immediate window
</div>

<div>
I have moved the move operation to a sub and bracketed it with a check for the null condition, a test showed that a null input to the delete block produces the reported error ... and now reading your post I think you knew it but I missed the connection. 
 
Chris 

<pre><code class="code-100 nolinks" id="code-286973">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
 For itm = 1 To masterList.count
 Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 Next
 'Stop
 For intItem = 1 To masterList.count
 itm = intItem
 Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 Next
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
 
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
Right after 25 i get the error 91 

</div>

<div>
Not able to reproduce the exact issue but there was a bug so please try this 
 
Chris 

<pre><code class="code-100 nolinks" id="code-287089">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intItem = 1 To masterList.count
 itm = intItem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
 
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
I get run time error 91 
When debug goes here 
&nbsp;src.MoveTo tgt 
When i take mouse over tgt i get 
 
tgt = &quot;Inbox&quot;
</div>

<div>
Can you see what src equates to? ... inbox is of course where the folder is to be moved to whereas src is the folder to be moved. 
 
Chris
</div>

<div>
Assuming it coresponds to something then in teh immediate window type ?src.folderpath and check for the existence of that folder. 
 
Chris
</div>

<div>
Src 
tgt = &quot;inbox&quot; 
When i put this 
 
?src.folderpath 
 
i get this 
 
--------------------------- 
Microsoft Visual Basic 
--------------------------- 
Run-time error '91': 
 
Object variable or With block variable not set 
--------------------------- 
OK &nbsp; Help &nbsp; 
--------------------------- 
 

</div>

<div>
Added some debugging here ... can you supply the output ... something like: 
 
Processing item 0,(\\Personal Folders\Inbox\fldr1) of 0 ... 1 
Processing item 1,(\\Personal Folders\Inbox\fldr2) of 0 ... 1 
 
Chris 

<pre><code class="code-100 nolinks" id="code-287165">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intItem = 1 To masterList.count
 itm = intItem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
 
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 Debug.Print &quot;Processing item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
Got a lot of data above this which just went off 
 
 
Same as below have the data from 2001 till this 
 
Processing item 2283,() of 0 ... 2289 
Processing item 2284,() of 0 ... 2289 
Processing item 2285,() of 0 ... 2289 
Processing item 2286,() of 0 ... 2289 
Processing item 2287,() of 0 ... 2289 
Processing item 2288,() of 0 ... 2289 
Processing item 2289,() of 0 ... 2289
</div>

<div>
It's showing as a lot of folders that are null, I simply don't understand as on my stand alone it doesn't happen and I don't have access to a network pc with outlook 2007. 
 
I will modify the output to a text file and then perhaps there will be more info. 
 
Chris 

<pre><code class="code-100 nolinks" id="code-287227">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intItem = 1 To masterList.count
 itm = intItem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 outputFilePathandName = Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set outputFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set outputFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then outputFile.WriteLine &quot;Processing item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
Can you ensure you are happy to provide the file CRBDataTrace.txt in your temp folder, (in explorer type %temp% in the folderpath. 
 
Chris
</div>

<div>
Chris send the mail with the txt
</div>

<div>
Every last one of them is empty ... I need to think a bit, because it works for me :{ 
 
in the meantime &nbsp;you arer running on an office 2007 installation? 
 
Chris
</div>

<div>
yes office 2007 is what i use....
</div>

<div>
Another quick hack to add some more data ... if you can upload it please? 
 
Chris 

<pre><code class="code-100 nolinks" id="code-287699">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 End If
 folderList.Add folderList.count + 1, startFolder.folderpath
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intItem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intItem = 1 To masterList.count
 itm = intItem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 outputFilePathandName = Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set outputFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set outputFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then outputFile.WriteLine &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then outputFile.WriteLine &quot;Processing item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
Hi Chris send a mail with the details.. 
 
I guess it pulled data from just 1 pst. the last one...
</div>

<div>
That's even stranger .. no folderpath data at all! 
 
I have modified the below to print to the immendiate window the folderpaths ffom earlier in the sequence. &nbsp;Given what happened I need only have an idea of the last few lines hence didn't bother putting it to the logfile. 
 
Note the error means the loop does not return to the initial loop on PSTs .. I hope, so that is why it appears as the mailbox only and is why I am ignoring those concerns for now. 
 
Chris 

<pre><code class="code-100 nolinks" id="code-288011">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 For intitem = 1 To allFolders.count
 Debug.Print intitem &amp; vbTab &amp; allFolders(intitem)
 Next
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 folderList.Add folderList.count + 1, startFolder.folderpath
 End If
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
I get runtime 424 When debug goes here 
 
&nbsp;Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp;&nbsp;&quot;\CRBDataTrace.txt&quot;)
</div>

<div>
Ah! 
 
I have started to move to a library file these sort of capabilities ... and I started here after my last post. 
 
For now append the following to the end of your code AND delete CRBDebug. including that 'dot' in the subroutine and retry 
 
Chris 

<pre><code class="code-10 nolinks" id="code-288027">Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
I get object required error 
When debug goes here 
&nbsp; &nbsp; &nbsp; &nbsp; If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot;&nbsp;&amp; itm &amp;&nbsp;&quot;, (&quot; &amp;&nbsp;dupes.Item(itm) &amp;&nbsp;&quot;)&quot; 
 
This is the full code i have now... 

<pre><code class="code-100 nolinks" id="code-288029">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 For intitem = 1 To allFolders.Count
 Debug.Print intitem &amp; vbTab &amp; allFolders(intitem)
 Next
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 folderList.Add folderList.Count + 1, startFolder.folderPath
 End If
 For Each Fldr In startFolder.Folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 Err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If Err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.Count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath Reddy\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.Folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.Folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.Folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.Folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
I get object required error 
When debug goes here 
&nbsp; &nbsp; &nbsp; &nbsp; If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot;&nbsp;&amp; itm &amp;&nbsp;&quot;, (&quot; &amp;&nbsp;dupes.Item(itm) &amp;&nbsp;&quot;)&quot; 
 
This is the full code i have now... 

<pre><code class="code-100 nolinks" id="code-288030">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 For intitem = 1 To allFolders.Count
 Debug.Print intitem &amp; vbTab &amp; allFolders(intitem)
 Next
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 folderList.Add folderList.Count + 1, startFolder.folderPath
 End If
 For Each Fldr In startFolder.Folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 Err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If Err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.Count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath Reddy\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.Folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.Folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.Folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.Folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
This is the reference I made to deleting crbdebug, (there were multiple references). &nbsp; done as below for you 
 
Chris 

<pre><code class="code-100 nolinks" id="code-288037">Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 For intitem = 1 To allFolders.Count
 Debug.Print intitem &amp; vbTab &amp; allFolders(intitem)
 Next
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 folderList.Add folderList.Count + 1, startFolder.folderPath
 End If
 For Each Fldr In startFolder.Folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 Err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If Err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.Count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = True
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath Reddy\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
 If db Then closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.Folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.Folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.Folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.Folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
It's actually the output in the immediate window I am looking for this time? 
 
Chris
</div>

<div>
I have moved some of the debug variables to globals so please replace with the full code as attached. &nbsp;The debug log file contains the data I 'want' this time. 
 
Chris 

<pre><code class="code-100 nolinks" id="code-288127">Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 db = True
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 If db Then CRBDebug.closeDebugFile outputFile
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 If db Then CRBDebug.writeLineDebugFile outputFile, folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 folderList.Add folderList.count + 1, startFolder.folderpath
 End If
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 Debug.Print folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
I get runtime error 424 
When debug goes here 
Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp;&nbsp;&quot;\CRBDataTrace.txt&quot;) 
I even tried removing 'CRBDebug.&quot; but no luck... :-( 
 
Sorry for being a pain on this...
</div>

<div>
Many apologies I lied ... this set should be better ... I forgot to add the debug subs as well as their names. 
 
Whilst the Q is a pain, I do not give up easily and it's not your fault ... yet :o). &nbsp;I truly do not understand why it works for me but not you, but hopefully all this fiddling will get us there. 
 
Chris 

<pre><code class="code-100 nolinks" id="code-288154">Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 db = True
 If db Then
 Set outputFile = openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 If db Then closeDebugFile outputFile
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 If db Then writeLineDebugFile outputFile, folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 folderList.Add folderList.count + 1, startFolder.folderpath
 End If
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 Debug.Print folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function 
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
Chris no errors now and i could see that it scanned all the folders fine &quot;2367&quot; and all had names. 
but just few are visible in the immediate window. 
I could not get any results as duplicate folders moving to the Inbox but did not get an error now
</div>

<div>
Another output to debug file 

<pre><code class="code-100 nolinks" id="code-288183">Option Explicit
Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 db = True
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;&quot;
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;&quot;
 If db Then CRBDebug.writeLineDebugFile outputFile, 1 &amp; &quot;:&quot; &amp; vbTab &amp; allFolders.Item(1)
 If db Then CRBDebug.writeLineDebugFile outputFile, allFolders.count &amp; &quot;:&quot; &amp; vbTab &amp; allFolders.Item(allFolders.count)
 If db Then CRBDebug.closeDebugFile outputFile
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 folderList.Add folderList.count + 1, startFolder.folderpath
 If db Then CRBDebug.writeLineDebugFile outputFile, folderList.count &amp; &quot;:&quot; &amp; vbTab &amp; folderList.Item(folderList.count)
 End If
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
Sorry assumed still would be problems ... I haven't fixed anything!
</div>

<div>
Hope you asked me to wait right.... 
Could not follow your last comment right
</div>

<div>
As I said I didn't fix anything but had commented out a long while back teh business end of the script but before I start to re-enable I will delete debug bits and see if still runs without error. &nbsp;Assuming it does i'll re-enable functionality 
 
Chris 

<pre><code class="code-100 nolinks" id="code-288205">Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 db = false
 If db Then
 Set outputFile = openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 If db Then closeDebugFile outputFile
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 If db Then writeLineDebugFile outputFile, folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 folderList.Add folderList.count + 1, startFolder.folderpath
 End If
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
' Debug.Print folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
' Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
 Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
' src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function 
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
No errors and the folders did not move
</div>

<div>
OK then hopefully moving teh files 
 
Chris 

<pre><code class="code-100 nolinks" id="code-288219">Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 db = false
 If db Then
 Set outputFile = openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 If db Then closeDebugFile outputFile
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 If db Then writeLineDebugFile outputFile, folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 folderList.Add folderList.count + 1, startFolder.folderpath
 End If
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
' Debug.Print folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function 
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
I get run time error 91 
When debug goes here 
&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; src.MoveTo tgt 
When i take the mouse over tgt i get 
 
tgt=&quot;inbox&quot; 
</div>

<div>
Trying to think what could have happened ... is there any chance thta some duplicated sub folder names themselves have sub folders? 
 
Chris
</div>

<div>
I dont think so but not sure :-((
</div>

<div>
A quick hack to skip errors and see if it helps. 
 
Chris 

<pre><code class="code-100 nolinks" id="code-288385">Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 db = false
 If db Then
 Set outputFile = openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 If db Then closeDebugFile outputFile
 Set allFolders = excludeDefaults(defaultFolders, allFolders)
 moveSome allFolders
 End If
 Next
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 If db Then writeLineDebugFile outputFile, folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 folderList.Add folderList.count + 1, startFolder.folderpath
 End If
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
' Debug.Print folderList.count &amp; vbTab &amp; startFolder.Name &amp; vbTab &amp; startFolder.folderpath
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;))
 If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
 If dupes.Exists(str) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; masterList.Item(itm)
 Else
 dupes.Add Key:=str, Item:=masterList.Item(itm)
 End If
 End If
 Next
 Set excludeDefaults = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Const db As Boolean = False
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 on error resume next
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function 
 
Function openDebugFile(outputFilePathandName As String) As Object
Dim outputFile As Object
Dim fso As Object
 
 Set fso = CreateObject(&quot;scripting.filesystemobject&quot;)
 If fso.FileExists(outputFilePathandName) Then
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, False)
 Else
 Set openDebugFile = fso.OpenTextFile(outputFilePathandName, 2, True)
 End If
 
End Function
 
Function closeDebugFile(outputFile As Object)
 outputFile.Close
End Function
 
Sub writeLineDebugFile(outputFile As Object, str As Variant)
Dim strline() As String
Dim cnt As Integer
 
 If IsArray(str) Then
 If InStr(str, vbCrLf) = 0 Then str = Replace(str, vbCr, vbCrLf)
 strline = Split(str, vbCrLf)
 For cnt = 0 To UBound(str)
 strline = str(cnt)
 outputFile.WriteLine strline
 Next
 Else
 outputFile.WriteLine str
 End If
 
End Sub
</code></pre>
</div>

<div>
Chris it does work i got say 9 folders moved to the inbox. 
Now my Q is did it scan all the folders and sub folders. 
And how does it consider it to be a duplicate 
1. Is case a matter 
2. Will the first word or all words be considered. 
3. Is any depth checked like 
 
inbox 
&gt;Sharath 
&gt;&gt;&nbsp;Ramesh 
&gt;&gt;&gt;&nbsp;Sharath 
Is this also checked. 
 
And now i just tested it for some time. 
 
Like i create a similar folder in all my 5 psts in the root and sub folders but not even one was moved... :-(
</div>

<div>
Does it scan all the folders and sub folders: 
&nbsp; &nbsp; Not exactly, if it finds a high level folder that meets the criterial it'll move that part of the folder tree 
 
Is case a matter ... shouldn't be since folder names are case insensitive 
 
Will the first word or all words be considered ... All 
 
THat said your comment that some are not processed concerns me BUT I'll not a chance to look again till tomorrow 
 
Chris
</div>

<div>
Ok no problem there are few folders that moved but when i manually tested it did not work
</div>

<div>
Okay a few issues in the code linked to the fact I assumed that the additional PST's would work whereas now I have implemented a second PST and tested that subject to the previous constraints. 
 
There was also a bug with case considerations that is also fixed. 
 
ONE PROVISO, the additional PST's MUST be uniquely named in the folder window. 
 
Fingers crossed! 
Chris 

<pre><code class="code-100 nolinks" id="code-289085">Option Explicit
Public outputFile As Object
Public outputFilePathandName As String
Public db As Boolean
 
Sub collateDupeFolders()
Dim olkApp As Application
Dim Fldr As MAPIFolder
Dim defaultFolders As Object
Dim allFolders As Object
Dim strStoresItem As Variant
Dim intitem As Integer
 
 Set defaultFolders = CreateObject(&quot;scripting.dictionary&quot;)
 Set allFolders = CreateObject(&quot;scripting.dictionary&quot;)
 For Each strStoresItem In Application.Session.Stores
 If Not strStoresItem.ExchangeStoreType = olExchangePublicFolder Then
 Set Fldr = Application.Session.GetFolderFromID(strStoresItem.StoreID)
 db = True
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 Call pf_findDefaults(Fldr, defaultFolders, allFolders)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;&quot;
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;&quot;
 If db Then CRBDebug.writeLineDebugFile outputFile, 1 &amp; &quot;:&quot; &amp; vbTab &amp; allFolders.Item(1)
 If db Then CRBDebug.writeLineDebugFile outputFile, allFolders.count &amp; &quot;:&quot; &amp; vbTab &amp; allFolders.Item(allFolders.count)
 If db Then CRBDebug.closeDebugFile outputFile
 End If
 Next
 excludeDefaults defaultFolders, allFolders
 moveSome allFolders
 
Set defaultFolders = Nothing
Set allFolders = Nothing
End Sub
 
Sub pf_findDefaults(ByRef startFolder As MAPIFolder, dict As Object, ByRef folderList As Object)
Dim Fldr As Outlook.MAPIFolder
 
 On Error Resume Next
 
 ' process all the subfolders of this folder
 If isDefaultFolder(startFolder) Then
 If Not dict.Exists(startFolder.Name) Then dict.Add startFolder.Name, startFolder.Name
 Else
 folderList.Add folderList.count + 1, startFolder.folderpath
 If db Then CRBDebug.writeLineDebugFile outputFile, folderList.count &amp; &quot;:&quot; &amp; vbTab &amp; folderList.Item(folderList.count)
 End If
 For Each Fldr In startFolder.folders
 Call pf_findDefaults(Fldr, dict, folderList)
 Next
 
Set Fldr = Nothing
End Sub
Function isDefaultFolder(Fldr As MAPIFolder) As Boolean
Dim oldName As String
 
 oldName = Fldr.Name
 On Error Resume Next
 err.Clear
 Fldr.Name = oldName &amp; &quot;ish&quot;
 If err.Number &lt;&gt; 0 Then
 isDefaultFolder = True
 Else
 Fldr.Name = oldName
 isDefaultFolder = False
 End If
 On Error GoTo 0
 
End Function
Function excludeDefaults(def As Object, ByRef masterList As Object) As Object
Dim itm As Variant
Dim dupes As Object
Dim str As String
Dim strFolder As Variant
Dim fldrs() As String
Dim src As Folder
Dim tgt As Folder
Dim folderindex As Integer
Dim intitem As Integer
 
 Set dupes = CreateObject(&quot;scripting.dictionary&quot;)
' For itm = 1 To masterList.count
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
' Next
 'Stop
 For intitem = 1 To masterList.count
 itm = intitem
' Debug.Print itm &amp; vbTab &amp; masterList.Item(itm)
 str = LCase(Right(masterList.Item(itm), Len(masterList.Item(itm)) - InStrRev(masterList.Item(itm), &quot;\&quot;)))
 If (InStr(3, masterList.Item(itm), &quot;\&quot;) &lt;&gt; 0) Then
 If Not def.Exists(str) Then
 If dupes.Exists(LCase(str)) Then
 dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; LCase(masterList.Item(itm))
 Else
 dupes.Add Key:=LCase(str), Item:=LCase(masterList.Item(itm))
 End If
 End If
 End If
' If Not def.Exists(str) And str &lt;&gt; &quot;Personal Folders&quot; Then
' If dupes.Exists(LCase(str)) Then
' dupes(str) = dupes(str) &amp; &quot;|&quot; &amp; LCase(masterList.Item(itm))
' Else
' dupes.Add Key:=LCase(str), Item:=LCase(masterList.Item(itm))
' End If
' End If
 Next
 Set masterList = dupes
End Function
Function moveSome(dupes As Object) As Object
Dim itm As Variant
Dim src As Folder
Dim tgt As Folder
Dim strFolder As String
Dim fldrs() As String
Dim folderindex As Integer
Dim outputFile As Object
Dim fso As Object
Dim outputFilePathandName As String
 
 If db Then
 Set outputFile = CRBDebug.openDebugFile(Environ(&quot;temp&quot;) &amp; &quot;\CRBDataTrace.txt&quot;)
 End If
 If dupes Is Nothing Then Exit Function
 For Each itm In dupes.Keys
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing item &quot; &amp; itm &amp; &quot;, (&quot; &amp; dupes.Item(itm) &amp; &quot;)&quot;
 If InStr(dupes.Item(itm), &quot;|&quot;) &gt; 0 Then
 fldrs = Split(dupes.Item(itm), &quot;|&quot;)
 For folderindex = 0 To UBound(fldrs)
 strFolder = fldrs(folderindex)
 If db Then CRBDebug.writeLineDebugFile outputFile, &quot;Processing Line item &quot; &amp; folderindex &amp; &quot;,(&quot; &amp; strFolder &amp; &quot;) of 0 ... &quot; &amp; UBound(fldrs)
 Set src = olNav2Folder(CStr(strFolder), False)
 Set tgt = olNav2Folder(&quot;\\Mailbox - Sharath\Inbox&quot;, True)
' Set tgt = olNav2Folder(&quot;\\Personal Folders\Inbox&quot;, True)
 src.moveto tgt
 Next
 End If
 Next
 If db Then CRBDebug.closeDebugFile outputFile
End Function
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
 On Error Resume Next
 foldername = Replace(Replace(foldername, &quot;/&quot;, &quot;\&quot;), &quot;\\&quot;, &quot;&quot;)
 If Right(foldername, 1) = &quot;\&quot; Then foldername = Left(foldername, Len(foldername) - 1)
 arrFolders() = Split(foldername, &quot;\&quot;)
 Set olApp = CreateObject(&quot;Outlook.Application&quot;)
 Set olNs = olApp.GetNamespace(&quot;MAPI&quot;)
 Set reqdFolder = olNs.folders.Item(arrFolders(0))
 For nestCount = 1 To UBound(arrFolders)
 If Not reqdFolder Is Nothing Then
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 If reqdFolder &lt;&gt; olfldr.Item(arrFolders(nestCount)) Then
 If createFolders Then
 reqdFolder.folders.Add (arrFolders(nestCount))
 Set olfldr = reqdFolder.folders
 Set reqdFolder = olfldr.Item(arrFolders(nestCount))
 Else
 Set reqdFolder = Nothing
 Exit For
 End If
 End If
 Else
 End If
 Next
 Set olNav2Folder = reqdFolder
 Set olApp = Nothing
 Set olNs = Nothing
 Set olfldr = Nothing
 Set reqdFolder = Nothing
End Function
</code></pre>
</div>

<div>
I get this 
 
--------------------------- 
Microsoft Visual Basic 
--------------------------- 
Compile error: 
 
Variable not defined 
--------------------------- 
OK &nbsp; Help &nbsp; 
--------------------------- 

</div>

<div>
Thanks a lot Chris at last we made it work. Its fast and acurate too. It works Awesome and was able to retrieve more than 100 duplicate folders... :-))) THANK YOU........................
</div>

<div>
<div class="content wysiwyg-content">
Hi, 
 
Move both or more duplicate folders to one folder and rename as needed. 
When macro run has to check my 4 pst's and see for a duplicate folder. 2 or more can be available and move them to a predefined folder path. 
Example 
\\Latest Mails\Inbox\JtoO\Microsoft 
\\Jan2009\Inbox\Vendors\Microsoft 
 
In the above case move &quot;Microsoft&quot; to a path. 
 
REgards 
Sharath
</div>
</div>

Hi,

Move both or more duplicate folders to one folder and rename as needed.
When macro run has to check my 4 pst's and see for a duplicate folder. 2 or more can be available and move them to a predefined folder path.
Example
\\Latest Mails\Inbox\JtoO\Microsoft
\\Jan2009\Inbox\Vendors\Microsoft

In the above case move "Microsoft" to a path.

REgards
Sharath

Move both or more duplicate folders to one folder and rename as needed.

Microsoft Outlook is a personal information manager from Microsoft, available as a part of the Microsoft Office suite. Although often used mainly as an email application, it also includes a calendar, task manager, contact manager, note-taker, journal, and web browser.

Outlook

Microsoft applications include a variety of software programs, including development and digital authoring programs (Expression and Media Center), educational programs, Internet software, including Essentials, Skype and the Live family, anti-virus, productivity applications and suites like Office, Excel, Word, Outlook, Access and PowerPoint, video games and server applications such as Exchange, SharePoint, IIS and Virtual Server.

Microsoft Applications

Microsoft Office is an integrated suite of applications that includes Outlook, Word, Excel, Access, PowerPoint, Visio and InfoPath, along with a number of tools to assist in making the individual components work together. Coding within and between the projects is done in Visual Basic for Applications, known as VBA.