Outlook Macro that needs to create folders and move mails from Sent folder. Does not work.

Hi there

your code from above...
You set olkTargetFolder = nothing.
Where do you re-establish it?
dmang

        Set olkTargetFolder = Nothing
        FindMatchingFolder olkRoot, strName
        If TypeName(olkTargetFolder) = "Nothing" Then
            Set olkTargetFolder = Session.GetDefaultFolder(olFolderSentMail).Folders.Add(strName)
        End If
        For intIndex = olkItems.Count To 1 Step -1
            Set olkItem = olkItems.Item(intIndex)
            olkItem.Move olkTargetFolder
        Next

dmang
Sorry did not follow...

OK then...
        Set olkTargetFolder = Nothing
        'you are removing the reference to olkTargetFolder

        FindMatchingFolder olkRoot, strName
        'don't know what this does

       'the ref to olkTargetFolder was removed above...will always be nothing
       If TypeName(olkTargetFolder) = "Nothing" Then
            Set olkTargetFolder = Session.GetDefaultFolder(olFolderSentMail).Folders.Add(strName)
        End If

dmang

dmang sorry gain this just goes out of my mind...
I have very less knowledge on scripting.. Please advice...

dmang sorry gain this just goes out of my mind...
I have very less knowledge on scripting.. Please advice...

When you set an object to Nothing, all information about it is lost.
In your code olkTargetFolder is set to nothing, and then you ask if Typename(olkTargetFolder) = "nothing"
It will always be nothing because it is set to nothing.

Oh ok... Now what do i need to set for it to move to the related created folders...

Send me the entire macro code, and I'll see what can be done.
dmang

The code in the question is the full code. Isnn't it

No...
        Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")
        Set olkTargetFolder = Nothing
        FindMatchingFolder olkRoot, strName
OpenOutlookFolder and FindMatching folder are functions that do no appear in your code above.

Will the remaining code be in thisoutlooksession

It could be ... or in a code module

In the code as supplied above right click on findmatchingfolder and select definition.  That should take you to the relevant sub and then post it here as it seems to be most likely culprit here.

Chris

Ha ok here is the code

Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If olkFolder.Name = strName Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub

Select allOpen in new window

MoveTenToSentItems does not have an obvoius global declaration for a folder so I assume olkTargetFolder  is local in scope to FindMatchingFolder.

This sub set the found folder to the olkTargetFolder  which is NOT available to the caller, (unless defined as a global somewhere).

Can you look around and see if you have a declaration for olkTargetFolder  somewhere and let me know how/where it is defined?

Chris

Sent an email

Sent an email

For general undersdtanding in the thread ... the supplied email is the FindMatchingFolder as above.

Sharath

Is there nowhere that olkTargetFolder   is formally defined, and if not then in teh containing folder enter a line at the top of the folder:

Public olkTargetFolder  As Object

Chris

I guess is it there in this code...

Private olkTargetFolder As Outlook.Folder
 
Sub Move_Mails_To_Folders()
'Excellent code to move all from inbox to folders
    'Change the folder path on the next two lines'
    Const ROOT1 = "All Mails\Inbox"
    Const ROOT2 = "Latest Mails\Inbox"
    Const ROOT3 = "Team Mails\Inbox"
    Const ROOT4 = "Jan2009\Inbox"
    'Change the number on the next line to that of the number of items required to trigger a move'
    Const MAXITEMS = 1
    Dim olkItems As Outlook.Items, _
        olkItem As Object, _
        olkRoot As Outlook.Folder, _
        objDict As Object, _
        arrNames As Variant, _
        arrNamePos As Variant, _
        varName As Variant, _
        intIndex As Integer
    Set objDict = CreateObject("Scripting.Dictionary")
    Set olkItems = Application.ActiveExplorer.CurrentFolder.Items
    olkItems.Sort "[SenderName]"
    For Each olkItem In olkItems
        On Error Resume Next
        If Not objDict.Exists(olkItem.SenderName) Then
            objDict.Add olkItem.SenderName, olkItem.SenderName
        End If
        On Error GoTo 0
    Next
    arrNames = objDict.Items()
    For Each varName In arrNames
        Set olkItems = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[SenderName] = '" & Replace(varName, "'", "''") & "'")
        If olkItems.Count >= MAXITEMS Then
            arrNamePos = Split(varName, " ")
            strName = Replace(Join(arrNamePos, " "), ",", "")
            Debug.Print varName & " = " & strName
            Set olkRoot = OpenOutlookFolder(ROOT1)
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, strName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT2)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT3)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT4)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) <> "Nothing" Then
                For intIndex = olkItems.Count To 1 Step -1
                    Set olkItem = olkItems.Item(intIndex)
                    olkItem.Move olkTargetFolder
                Next
            End If
        End If
    Next
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkTargetFolder = Nothing
    Set objDict = Nothing
    MsgBox "Finished"
End Sub
 
Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If olkFolder.Name = strName Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub

Select allOpen in new window

In the code block below you check for the 'required' folder name as derived from teh subject.  Where the folder does not pre-exist I cannot see any attempt to create it.  I presume you would like to add the folder to ONE of your PST's so any info on teh 'requirement' in this regard will help.

Chris

            Set olkRoot = olNav2Folder(ROOT1)
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, strName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = olNav2Folder(ROOT2)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = olNav2Folder(ROOT3)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = olNav2Folder(ROOT4)
                FindMatchingFolder olkRoot, strName
            End If

Select allOpen in new window

Ok here is the code that creates folders and moves mails

Sub Move_Mails_Excess()
  
Dim olapp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim myfolder As Outlook.MAPIFolder
Dim targetFolder As Outlook.MAPIFolder
Dim olMailItems As Outlook.Items
Dim mailcount As Integer
Dim mailCounter As Integer
Dim senderCounter As Integer
Dim mai As Outlook.MailItem
Dim strFilter As String
    On Error Resume Next
    
    Set olapp = Outlook.Application
    Set objns = olapp.GetNamespace("MAPI")
    Set myfolder = olapp.ActiveExplorer.CurrentFolder
'    For Each mai In MyFolder.Items
    For mailCounter = myfolder.Items.Count To 1 Step -1
        Set mai = myfolder.Items(mailCounter)
'        Debug.Print mai.SenderEmailAddress & vbTab & mai.SenderName
        strFilter = "[SenderName] = " & append_quotes(mai.SenderName)
        Set olMailItems = myfolder.Items.Restrict(strFilter)
        mailcount = olMailItems.Count
        If mailcount >= 1 Then
            Set targetFolder = FindFolder(olMailItems.Item(1).SenderName, myfolder)
            Debug.Print olMailItems.Item(1).SenderName & ", (" & mailcount & " items)."
            For senderCounter = mailcount To 1 Step -1
                olMailItems.Item(senderCounter).Move targetFolder
            Next
        End If
    Next
    
Set olMailItems = Nothing
Set objns = Nothing
Set olapp = Nothing
Set myfolder = Nothing
 
End Sub
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
Function FindFolder(sender As String, parentFolder As Outlook.MAPIFolder) As Outlook.MAPIFolder
Dim str_folder As String
Dim ol_app As Outlook.Application
Dim OL_namespace As Outlook.NameSpace
Dim OL_Folders As Outlook.Folders
Dim Required_Folder As Outlook.MAPIFolder
Dim arr_folders() As String
Dim nest_count As Integer
 
    str_folder = parentFolder.folderPath & "\" & sender
    
    
    On Error Resume Next
    If Right(str_folder, 1) = "\" Then str_folder = Left(str_folder, Len(str_folder) - 1)
    str_folder = Replace(str_folder, "\\", "")
    arr_folders() = Split(str_folder, "\")
    Set ol_app = CreateObject("outlook.application")
    Set OL_namespace = ol_app.GetNamespace("MAPI")
    Set Required_Folder = OL_namespace.Folders.Item(arr_folders(0))
    If Not Required_Folder Is Nothing Then
        For nest_count = 1 To UBound(arr_folders)
            Set OL_Folders = Required_Folder.Folders
            Set Required_Folder = Nothing
            Set Required_Folder = OL_Folders.Item(arr_folders(nest_count))
            If Required_Folder Is Nothing Then Set Required_Folder = OL_Folders.Add(arr_folders(nest_count))
        Next
    End If
    Set FindFolder = Required_Folder
    Set ol_app = Nothing
    Set OL_namespace = Nothing
    Set OL_Folders = Nothing
    Set Required_Folder = Nothing
End Function

Select allOpen in new window

Ok here is the code that creates folders and moves mails

Sub Move_Mails_Excess()
  
Dim olapp As Outlook.Application
Dim objns As Outlook.NameSpace
Dim myfolder As Outlook.MAPIFolder
Dim targetFolder As Outlook.MAPIFolder
Dim olMailItems As Outlook.Items
Dim mailcount As Integer
Dim mailCounter As Integer
Dim senderCounter As Integer
Dim mai As Outlook.MailItem
Dim strFilter As String
    On Error Resume Next
    
    Set olapp = Outlook.Application
    Set objns = olapp.GetNamespace("MAPI")
    Set myfolder = olapp.ActiveExplorer.CurrentFolder
'    For Each mai In MyFolder.Items
    For mailCounter = myfolder.Items.Count To 1 Step -1
        Set mai = myfolder.Items(mailCounter)
'        Debug.Print mai.SenderEmailAddress & vbTab & mai.SenderName
        strFilter = "[SenderName] = " & append_quotes(mai.SenderName)
        Set olMailItems = myfolder.Items.Restrict(strFilter)
        mailcount = olMailItems.Count
        If mailcount >= 1 Then
            Set targetFolder = FindFolder(olMailItems.Item(1).SenderName, myfolder)
            Debug.Print olMailItems.Item(1).SenderName & ", (" & mailcount & " items)."
            For senderCounter = mailcount To 1 Step -1
                olMailItems.Item(senderCounter).Move targetFolder
            Next
        End If
    Next
    
Set olMailItems = Nothing
Set objns = Nothing
Set olapp = Nothing
Set myfolder = Nothing
 
End Sub
Function append_quotes(objString As String) As String
    append_quotes = Chr(34) & CStr(objString) & Chr(34)
End Function
Function FindFolder(sender As String, parentFolder As Outlook.MAPIFolder) As Outlook.MAPIFolder
Dim str_folder As String
Dim ol_app As Outlook.Application
Dim OL_namespace As Outlook.NameSpace
Dim OL_Folders As Outlook.Folders
Dim Required_Folder As Outlook.MAPIFolder
Dim arr_folders() As String
Dim nest_count As Integer
 
    str_folder = parentFolder.folderPath & "\" & sender
    
    
    On Error Resume Next
    If Right(str_folder, 1) = "\" Then str_folder = Left(str_folder, Len(str_folder) - 1)
    str_folder = Replace(str_folder, "\\", "")
    arr_folders() = Split(str_folder, "\")
    Set ol_app = CreateObject("outlook.application")
    Set OL_namespace = ol_app.GetNamespace("MAPI")
    Set Required_Folder = OL_namespace.Folders.Item(arr_folders(0))
    If Not Required_Folder Is Nothing Then
        For nest_count = 1 To UBound(arr_folders)
            Set OL_Folders = Required_Folder.Folders
            Set Required_Folder = Nothing
            Set Required_Folder = OL_Folders.Item(arr_folders(nest_count))
            If Required_Folder Is Nothing Then Set Required_Folder = OL_Folders.Add(arr_folders(nest_count))
        Next
    End If
    Set FindFolder = Required_Folder
    Set ol_app = Nothing
    Set OL_namespace = Nothing
    Set OL_Folders = Nothing
    Set Required_Folder = Nothing
End Function

Select allOpen in new window

>>>Ok here is the code that creates folders and moves mails

But this isn't in the scope of the relevant function Move_Mails_To_Folders as above.

i.e. it isn't called so we are still left with how the original sub should react to a missing folder.

Chris

If the folder is missing then just leave the mail in the sent folder itself.

For this Q...
We need to create folders that are in the TO box names and move the mails to the created folders.

If the folder is missing then just leave the mail in the sent folder itself.

For this Q...
We need to create folders that are in the TO box names and move the mails to the created folders.

Am I missing something?

For this Q...
We need to create folders that are in the TO box names and move the mails to the created folders.

>>> If the folder is missing then just leave the mail in the sent folder itself.

Either create it or not .. can't have both ;o) and currently it does not create the folder.

My problem is with the original statement:

>>> The folders are created but all mails get into 1 single named folder.

As far as I can see the folders are created in this application and if they do not exist at the time of running they will stay in the folder so what am I missing?

Chris

Ok...

What i need is Create folders in the sent folder and move all mails to its relevant folder
Say i have sent a mail to Chris.And that mail is in the Sent item. When macro run has to create a folder and move Chris mails there. If folder already exists then move the mail to the already existing folder

Ok...

What i need is Create folders in the sent folder and move all mails to its relevant folder
Say i have sent a mail to Chris.And that mail is in the Sent item. When macro run has to create a folder and move Chris mails there. If folder already exists then move the mail to the already existing folder

>>> Say i have sent a mail to Chris.And that mail is in the Sent item. When macro run has to create a folder and move Chris mails there. If folder already exists then move the mail to the already existing folder

1. Which PST?:
    Const ROOT1 = "Personal Folders\Inbox"
    Const ROOT2 = "Latest Mails\Inbox"
    Const ROOT3 = "Team Mails\Inbox"
    Const ROOT4 = "Jan2009\Inbox"

2. Inbox\chris\Received or inbox\chris\chris ... i.e. picking up on the other email?

Chris

I have it in all my sent mails
\\All Mails\Sent

I want them moved to
Const ROOT2 = "Latest Mails\Inbox"
Const ROOT3 = "Team Mails\Inbox"

Find the folder Chris in the 2 psts. When found create a folder "Sent" and move the mails from Sent to this folder. If folder not found leave the mails in sent itself.

I have it in all my sent mails
\\All Mails\Sent

I want them moved to
Const ROOT2 = "Latest Mails\Inbox"
Const ROOT3 = "Team Mails\Inbox"

Find the folder Chris in the 2 psts. When found create a folder "Sent" and move the mails from Sent to this folder. If folder not found leave the mails in sent itself.

One change to try in the Move_Mails_To_Folders sub.  Keep all the other modules as is and simply replace this one.

Chris

Sub Move_Mails_To_Folders()
'Excellent code to move all from inbox to folders
    'Change the folder path on the next two lines'
    Const ROOT1 = "All Mails\Inbox"
    Const ROOT2 = "Latest Mails\Inbox"
    Const ROOT3 = "Team Mails\Inbox"
    Const ROOT4 = "Jan2009\Inbox"
    'Change the number on the next line to that of the number of items required to trigger a move'
    Const MAXITEMS = 1
    Dim olkItems As Outlook.Items, _
        olkItem As Object, _
        olkRoot As Outlook.Folder, _
        objDict As Object, _
        arrNames As Variant, _
        arrNamePos As Variant, _
        varName As Variant, _
        intIndex As Integer
    Set objDict = CreateObject("Scripting.Dictionary")
    Set olkItems = Application.ActiveExplorer.CurrentFolder.Items
    olkItems.Sort "[SenderName]"
    For Each olkItem In olkItems
        On Error Resume Next
        If Trim(olkItem.SenderName) <> "" Then
            If Not objDict.Exists(olkItem.SenderName) Then
                objDict.Add olkItem.SenderName, olkItem.SenderName
            End If
        End If
        On Error GoTo 0
    Next
    arrNames = objDict.Items()
    For Each varName In arrNames
        Set olkItems = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[SenderName] = '" & Replace(varName, "'", "''") & "'")
        If olkItems.Count >= MAXITEMS Then
            arrNamePos = Split(varName, " ")
            strName = Replace(Join(arrNamePos, " "), ",", "")
            Debug.Print varName & " = " & strName
            Set olkRoot = OpenOutlookFolder(ROOT1)
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, strName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT2)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT3)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT4)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) <> "Nothing" Then
                For intIndex = olkItems.Count To 1 Step -1
                    Set olkItem = olkItems.Item(intIndex)
                    olkItem.Move olkTargetFolder
                Next
            End If
        End If
    Next
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkTargetFolder = Nothing
    Set objDict = Nothing
    MsgBox "Finished"
End Sub

Select allOpen in new window

Chris...
Thanks...
Can i know what it does and should i run it on Inbox or sent items...

>>> Can i know what it does and should i run it on Inbox or sent items.
From previous code I know there are problems where the array entries are null, so the change is simply to handle null entries on teh assumption that the code is falling over for exactly that reason.

At this point it simply moves the items to the inbox as per the principle of identifying what is broken in teh original code.  As such I think it should be run on the inbox only to make it easier to subsequently move the mailitems to a subfolder structure as under discussion.

        If Trim(olkItem.SenderName) <> "" Then ' New line entered
            If Not objDict.Exists(olkItem.SenderName) Then
                objDict.Add olkItem.SenderName, olkItem.SenderName
            End If
        End If ' Matching new line entered

Chris

Chris
The inbox code works perfect the Sent folder code is the one not running.

Say when i run on the inbox the mails i have received need to be queried and when run on the sent the Mails sent to person has to be queried.

Now when i run on sent then a folder has to be created with your name and moved all your mails that i have sent to you. Thats what is not working

Chris
The inbox code works perfect the Sent folder code is the one not running.

Say when i run on the inbox the mails i have received need to be queried and when run on the sent the Mails sent to person has to be queried.

Now when i run on sent then a folder has to be created with your name and moved all your mails that i have sent to you. Thats what is not working

So this same code is run for both sent and inbox folders?

Chris

No
The code in the Question is run for all sent items
The code here is run for inbox
ID: 24075352
The code in the Q is the one that does not work.
As Sent and received have to be moved in different ways
Like when i receive from you I need to check on the "From box". And when quering the sent need to check the "To box"

No
The code in the Question is run for all sent items
The code here is run for inbox
ID: 24075352
The code in the Q is the one that does not work.
As Sent and received have to be moved in different ways
Like when i receive from you I need to check on the "From box". And when quering the sent need to check the "To box"

As I see it, and unfortunately this will offend one or more experts involved, (who knows me included!) but MoveTenToSentItems is flawed.

1. Does not clear the error ... I have added err.clear as below
        If err.Number <> 0 Then
            MsgBox olkItem.subject
            err.Clear
        End If

2. The main loop, (For Each varName In arrNames) for moving mailitems does NOT use a fixed value on which to filter, (i.e. replace operations - and yes I added trim as well)  In the code however there is the move construct:
        For intIndex = olkItems.count To 1 Step -1
            Set olkItem = olkItems.Item(intIndex)
            olkItem.Move olkTargetFolder
        Next

which moves ALL mailitems in the sent folder to the targetfolder ... therefore subsequent attempts find nothing in the sent folder.  The use of the dictionary implies use of a filter but this is not set up and nor does the trim/replace of the key data support this.  Fundamentally therefore and in my opinion the sub is flawed so do you want it fixing or take the opportunity to rethink your overall methodology - no offence intended but you did start that particular discussion!

Chris

Hi Chris,
Ok...
At this moveent if we can get this code to work then that would be great . At this point i want the mails in the sent to be moved to the newly created folders.
After which shall post more Q...s of the Moe folders and move mails to sent folders....

At it's simplest try the snippet.  There is no filter applied so each email is processed 1 by 1, i'm not aware if a filter works on the recipient field but some kind of filter will be advisable in the future to speed it up.

Please note that it will be painfully slow as is but at least it will move the mails to the subfolders now.  If you want with a small mod it can grab for example 100 items at a time and then process them coming to a clean stop.

Chris

Sub MoveTenToSentItems()
    Dim olkItems As Outlook.items, _
        olkItem As Object, _
        olkRoot As Outlook.Folder, _
        objDict As Object, _
        arrNames As Variant, _
        arrNamePos As Variant, _
        varName As Variant, _
        intIndex As Integer, _
        strName As String
    On Error Resume Next
'    Set objDict = CreateObject("Scripting.Dictionary")
    Set olkItems = Application.ActiveExplorer.CurrentFolder.items
    Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")
    Set olkRoot = OpenOutlookFolder("Personal Folders\Sent Items")
    For Each olkItem In olkItems
        varName = Trim(Replace(olkItem.Recipients.Item(1).Name, "'", ""))
        If err.Number <> 0 Then
            MsgBox olkItem.subject
            err.Clear
        ElseIf varName <> "" Then
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, varName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkTargetFolder = olkRoot.folders.Add(strName)
            End If
            olkItem.Move olkTargetFolder
        End If
    Next
    
    
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkTargetFolder = Nothing
    Set objDict = Nothing
    On Error GoTo 0
    MsgBox "Finished"
End Sub

Select allOpen in new window

I see a bug

Chris

Sub MoveTenToSentItems()
    Dim olkItems As Outlook.items, _
        olkItem As Object, _
        olkRoot As Outlook.Folder, _
        objDict As Object, _
        arrNames As Variant, _
        arrNamePos As Variant, _
        varName As Variant, _
        intIndex As Integer, _
        strName As String
    On Error Resume Next
'    Set objDict = CreateObject("Scripting.Dictionary")
    Set olkItems = Application.ActiveExplorer.CurrentFolder.items
    Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")
    Set olkRoot = OpenOutlookFolder("Personal Folders\Sent Items")
    For Each olkItem In olkItems
        varName = Trim(Replace(olkItem.Recipients.Item(1).Name, "'", ""))
        If err.Number <> 0 Then
            MsgBox olkItem.subject
            err.Clear
        ElseIf varName <> "" Then
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, varName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkTargetFolder = olkRoot.folders.Add(varName)
            End If
            olkItem.Move olkTargetFolder
        End If
    Next
    
    
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkTargetFolder = Nothing
    Set objDict = Nothing
    On Error GoTo 0
    MsgBox "Finished"
End Sub

Select allOpen in new window

Thanks Chris Can we stop the code every 100

To confirm.
Will the macro run on this path
 Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")

Create folders with sent to persons names

As per the original macro it works on th ecurrent folder, so if the current folder is the sent folder then yes it creates a subfolder for the (first) recipients name and moves the mail(s) therein.

Chris

Hi Chris sorry for the delay in response... I had to go to my home town on an Urgent requirment

Ok I have say 10 mails in the mailbox\sent folder and when i run nothing happens
Now what are these 2 lines for
Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")
    Set olkRoot = OpenOutlookFolder("Personal Folders\Sent Items")
It does not create any folders on the selected sent items

Okay:

I don't have latest emails PST so I added the second line for testing ... disable it:

Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")
'Set olkRoot = OpenOutlookFolder("Personal Folders\Sent Items")

Chris

Thanks Chris
Ok i kept 10 mails in this path
Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")
And when run say 5 times only then the mails were moved to the created folders... But did not create and move all in 1 shot but i had to run the script 5 times and say 2 out of them did not move

Say i have Chris mail in sent and already a folder created for the name Chris when run again the existing mail Chris does not move to the already created folder

The whole concept is perfect now...
Except few changes

What does this line mean
intItemCount = 100

There are many folders created and for many they are not created is there any specific reason

>>> Thanks Chris Can we stop the code every 100

Chris

Ya but it does not stop in 100. As i said when i have 10 it moved 8 and when i had 150 mails it moved 58 mails and created the folders but did not move the 92 mails.

The relevant code is:

            FindMatchingFolder olkRoot, varName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkTargetFolder = olkRoot.folders.Add(varName)
            End If
            olkItem.Move olkTargetFolder
 
It is all driven off varname and either the existing folder is found or the folder is created.  If it is missing movements then those movements bust be being moved to the root therefore since:

varName = Trim(Replace(olkItem.Recipients.Item(1).Name, "'", ""))

You need to provide accurate examples of moved and unmoved mailitems ... you need to check for equivalence yourself since a hard space could cause issues.

Chris

Ok can i get a popup
That i can use to select instead of the harcoded name please
So when it asks me to select the folder. I can select a folder or sent folder manually myself
And
When first run Chris mails created a folder and moved the mails i sent to you. And when i moved 1 mail from the chris folder to the sent folder and again run the script it does not move the mail to the folder Chris that is already created...

Can you do a search on your code module and see if olkTargetFolder is declared in more than 1 place ... maybe public or local and if any subs are in different modules then also a check there for the definition(s)

Chris

Yes there are many places where i could find this
Private olkTargetFolder As Outlook.Folder
and  as this

Private Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If LCase(olkFolder.Name) = LCase(strName) Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub

MOst likely then it is an erroneous declaration ... can you supply all code in modules where it is defined i.e.
Private olkTargetFolder As Outlook.Folder
or
Dim olkTargetFolder As Outlook.Folder
or
Public olkTargetFolder As Outlook.Folder

OR alternatively of course check for yourself to make sure tehre isn't a declaration in the scope of FindMatchingFolder that is affecting the working.

Chris

Here is the code
I cannot find any code haveing these
Dim olkTargetFolder As Outlook.Folder
or
Public olkTargetFolder As Outlook.Folder

Private olkTargetFolder As Outlook.Folder
 
Sub Move_Mails_To_Folders()
'Excellent code to move all from inbox to folders
    'Change the folder path on the next two lines'
    Const ROOT1 = "All Mails\Inbox"
    Const ROOT2 = "Latest Mails\Inbox"
    Const ROOT3 = "Team Mails\Inbox"
    Const ROOT4 = "Jan2009\Inbox"
    'Change the number on the next line to that of the number of items required to trigger a move'
    Const MAXITEMS = 1
    Dim olkItems As Outlook.Items, _
        olkItem As Object, _
        olkRoot As Outlook.Folder, _
        objDict As Object, _
        arrNames As Variant, _
        arrNamePos As Variant, _
        varName As Variant, _
        intIndex As Integer
    Set objDict = CreateObject("Scripting.Dictionary")
    Set olkItems = Application.ActiveExplorer.CurrentFolder.Items
    olkItems.Sort "[SenderName]"
    For Each olkItem In olkItems
        On Error Resume Next
        If Not objDict.Exists(olkItem.SenderName) Then
            objDict.Add olkItem.SenderName, olkItem.SenderName
        End If
        On Error GoTo 0
    Next
    arrNames = objDict.Items()
    For Each varName In arrNames
        Set olkItems = Application.ActiveExplorer.CurrentFolder.Items.Restrict("[SenderName] = '" & Replace(varName, "'", "''") & "'")
        If olkItems.Count >= MAXITEMS Then
            arrNamePos = Split(varName, " ")
            strName = Replace(Join(arrNamePos, " "), ",", "")
            Debug.Print varName & " = " & strName
            Set olkRoot = OpenOutlookFolder(ROOT1)
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, strName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT2)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT3)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkRoot = OpenOutlookFolder(ROOT4)
                FindMatchingFolder olkRoot, strName
            End If
            If TypeName(olkTargetFolder) <> "Nothing" Then
                For intIndex = olkItems.Count To 1 Step -1
                    Set olkItem = olkItems.Item(intIndex)
                    olkItem.Move olkTargetFolder
                Next
            End If
        End If
    Next
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkTargetFolder = Nothing
    Set objDict = Nothing
    MsgBox "Finished"
End Sub
 
Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If olkFolder.Name = strName Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub

Select allOpen in new window

And this code

Private olkTargetFolder As Outlook.Folder
 
Sub Create_Folders_From_Excel()
'Excellent script to check colum A excel names and create folders only if not founs
'Even place the task if done or not in the excel colum B
    'Change the folder paths on the next two lines as needed'
    Const ROOT1 = "All Mails\Inbox"
    Const ROOT2 = "Latest Mails\Inbox"
    Dim excApp As Object, _
        excBook As Object, _
        excSheet As Object
    Dim olkRoot As Outlook.Folder
    Dim intIndex As Integer, _
        strName As String
    Set excApp = CreateObject("Excel.Application")
    'Change the file name and path on the next line as needed'
    Set excBook = excApp.Workbooks.Open("D:\Names1.xlsx")
    Set excSheet = excBook.Worksheets(1)
    'Change the value of intIndex to point to the first row of data in the spreadsheet'
    intIndex = 1
    Do Until excSheet.Cells(intIndex, 1) = ""
        strName = excSheet.Cells(intIndex, 1)
        Set olkRoot = OpenOutlookFolder(ROOT1)
        Set olkTargetFolder = Nothing
        FindMatchingFolder olkRoot, strName
        If TypeName(olkTargetFolder) = "Nothing" Then
            Set olkRoot = OpenOutlookFolder(ROOT2)
            FindMatchingFolder olkRoot, strName
            If TypeName(olkTargetFolder) = "Nothing" Then
                OpenOutlookFolder("Latest Mails\Inbox\Raja").Folders.Add strName
                excSheet.Cells(intIndex, 2) = "Added"
            Else
                excSheet.Cells(intIndex, 2) = "Found"
            End If
        Else
            excSheet.Cells(intIndex, 2) = "Found"
        End If
        intIndex = intIndex + 1
    Loop
    Set excSheet = Nothing
    excBook.Save
    Set excBook = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkRoot = Nothing
    MsgBox "Done"
End Sub
 
Private Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If LCase(olkFolder.Name) = LCase(strName) Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub

Select allOpen in new window

So correct me if I am wrong but there isn't a copy of olkTargetFolder in the same module as MoveTenToSentItems?

That being so take a copy and drop it into the same module and retry.

Chris

olkTargetFolder no its not there
Can you give me the code that has to be within the code you gave me here

At the top of module but under option explicit - if defined paste:

Private olkTargetFolder As Outlook.Folder

And at the end of the module add:

Private Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If LCase(olkFolder.Name) = LCase(strName) Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub

What is the addition for. Just to know what is the difference i can find. As i could not find any change

Below is the full code i have

Private olkTargetFolder As Outlook.Folder
 
Sub MoveTenToSentItems1()
    Dim olkItems As Outlook.Items, _
        olkItem As Object, _
        olkRoot As Outlook.Folder, _
        objDict As Object, _
        arrNames As Variant, _
        arrNamePos As Variant, _
        varName As Variant, _
        intIndex As Integer, _
        strName As String, _
        lngitemPointer As Long, _
        lnglastitem As Long, _
        intItemCount As Integer
    On Error Resume Next
    
    intItemCount = 1
    Set olkItems = Application.ActiveExplorer.CurrentFolder.Items
    Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")
    'Set olkRoot = OpenOutlookFolder("Personal Folders\Sent Items")
    lnglastitem = olkItems.Count
    If olkItems.Count <= intItemCount Then
        lnglastitem = 1
    Else
        lnglastitem = lnglastitem - intItemCount
    End If
    For lngitemPointer = olkItems.Count To lnglastitem Step -1
        Err.Clear
        Set olkItem = olkItems(lngitemPointer)
        varName = Trim(Replace(olkItem.Recipients.Item(1).Name, "'", ""))
        If Err.Number <> 0 Then
            MsgBox olkItem.Subject
            Err.Clear
        ElseIf varName <> "" Then
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, varName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkTargetFolder = olkRoot.Folders.Add(varName)
            End If
            olkItem.Move olkTargetFolder
        End If
    Next
    
    
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkTargetFolder = Nothing
    Set objDict = Nothing
    On Error GoTo 0
End Sub
Private Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If LCase(olkFolder.Name) = LCase(strName) Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub

Select allOpen in new window

As far as I can infer from the information provided ... or at least my understanding of it "I THINK" what may have been happening is that some bits of code used a local declaration of the variable / frunction that worked and some didn't.  Putting them all into one module will ensure the local 'copy' is used by all and ought to reflect my own tests which worked ok ... and the nature of the code itself doesn't lend itself to some of the previous esoteric errors.

It all hinges of course on what happens when you try it! since it may have made no difference at all :o(

Chris

Hi Chris i guess its working but have a few issues

i get some message boxes. What are they for.
For an external mail if for few i get the folders created as
Sharath@plc.com
Yes they are external cant i get as
Sharath

Hi Chris i guess its working but have a few issues

i get some message boxes. What are they for.
For an external mail if for few i get the folders created as
Sharath@plc.com
Yes they are external cant i get as
Sharath

The message box is triggered when a mail in a folder does not seem to have a recipient ... i.e. not an email , an invite or unsent message.

The output can be turned off easily enough if you simply want to ignore such items.

I don't follow the other comment?

Chris

What i meant is
For a few mails that the folders get created they are created as this
Sharath@plc.com
Where as it has to be created as 'Sharath"

For an external mail if for few i get the folders created as
Sharath@plc.com
Yes they are external cant i get as
Sharath

You want to cut the folder name off at the "@" symbol?

Chris

Sorry

You want to cut all folder names off at the "@" symbol

Ya for external mails cut before @ and for the internal mails leave as they are

We had agreed to resolve the current format and then modify it in stages as necessary ... or if that wasn't this thread then we need to do it the same.

IN that regard the original macro did not differentiate between internal and external so nor should this answer ... which is in regard to all the emails going into the one folder.

As such I am happy to modify it so any email with an @ symbol is 'trimmed'.  Is that acceptable?

If so this is as below and the msgbox is disbled as well.

Chris

Private olkTargetFolder As Outlook.Folder
 
Sub MoveTenToSentItems1()
    Dim olkItems As Outlook.Items, _
        olkItem As Object, _
        olkRoot As Outlook.Folder, _
        objDict As Object, _
        arrNames As Variant, _
        arrNamePos As Variant, _
        varName As Variant, _
        intIndex As Integer, _
        strName As String, _
        lngitemPointer As Long, _
        lnglastitem As Long, _
        intItemCount As Integer
    On Error Resume Next
    
    intItemCount = 1
    Set olkItems = Application.ActiveExplorer.CurrentFolder.Items
    Set olkRoot = OpenOutlookFolder("Latest Mails\Sent Items")
    'Set olkRoot = OpenOutlookFolder("Personal Folders\Sent Items")
    lnglastitem = olkItems.Count
    If olkItems.Count <= intItemCount Then
        lnglastitem = 1
    Else
        lnglastitem = lnglastitem - intItemCount
    End If
    For lngitemPointer = olkItems.Count To lnglastitem Step -1
        Err.Clear
        Set olkItem = olkItems(lngitemPointer)
        varName = Trim(Replace(olkItem.Recipients.Item(1).Name, "'", ""))
        if instr(varname, "@") > 0 then _
            varname = left(varname, instr(varname, "@")-1)
        If Err.Number <> 0 Then
'            MsgBox olkItem.Subject
            Err.Clear
        ElseIf varName <> "" Then
            Set olkTargetFolder = Nothing
            FindMatchingFolder olkRoot, varName
            If TypeName(olkTargetFolder) = "Nothing" Then
                Set olkTargetFolder = olkRoot.Folders.Add(varName)
            End If
            olkItem.Move olkTargetFolder
        End If
    Next
    
    
    Set olkItems = Nothing
    Set olkItem = Nothing
    Set olkTargetFolder = Nothing
    Set objDict = Nothing
    On Error GoTo 0
End Sub
Private Sub FindMatchingFolder(olkFolder As Outlook.Folder, ByVal strName As String)
    Dim olkSubFolder As Outlook.Folder
    If LCase(olkFolder.Name) = LCase(strName) Then
        Set olkTargetFolder = olkFolder
    Else
        For Each olkSubFolder In olkFolder.Folders
            FindMatchingFolder olkSubFolder, strName
        Next
    End If
    Set olkSubFolder = Nothing
End Sub 
Open in New Window Select All 

Select allOpen in new window

Thanks a lot Chris the accepted answer is fine and its very few i get the full email id created so i shall do them manually....
Thanks a lot for this help....

sent a mail to you on the 2nd post help... :-))

Hi Chris any help on this
https://www.experts-exchange.com/questions/24315485/Move-folders-in-the-sent-folders-to-a-particular-location-matching-the-folder-names.html