Looking for a macro that moves completed items from subfolders to other subfolder

[sophievldn]

Hello everyone,

I'm new to Outlook VBA and I've been trying to find a macro that would move emails that I mark as complete (that are already inside different subfolders of my inbox) to another subfolder called "DONE". I can't seem to find it online and I'm not great at experimenting with Outlook VBA. Can anyone help me?

Thanks!
Sophie

 

[Diane Poremsky]

This macro gets close to what you want - instead of sending mail, you will need to move. Are you moving to one folder called done or will there be more than one folder the messages are moved to?

Create a Task when a Message is Flagged

Use the ItemChange event to run a macro when an Outlook item is changed. In this example, a task is created when the Quick Click Flag is clicked.

www.slipstick.com

 

[sophievldn]

Thank you for your reply Diane! There will only be one folder the messages will be moved into.

 

[Diane Poremsky]

This is a quickie with the basics, but it only works on messages in the inbox.

If you have a lot of folders, it might be better to run a macro at the end of the day (or manually at any time) to move the marked messages.

Public WithEvents OlItems As Outlook.Items

Public Sub Initialize_handler()
   Set OlItems = Application.GetNamespace("MAPI"). _
        GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub OlItems_ItemChange(ByVal Item As Object)
     
Dim NS As Outlook.NameSpace
Dim fldInbox As Outlook.Folder
Dim fldDone As Outlook.Folder

Set NS = Application.GetNamespace("MAPI")
Set fldInbox = NS.GetDefaultFolder(olFolderInbox)

'subfolder of Inbox
Set fldDone = fldInbox.Folders("Finished")


If Item.Categories = "Done" Then
Item.Move fldDone
End If

End Sub

 

[sophievldn]

Awesome, thanks Diane! This works!
Is it possible to tweak it so it moves all messages marked as done from the following three folders into the done folder, instead of only from the inbox?
"processing"
"cc mail"
"on hold"
"follow up"

I don't mind if this macro only runs once a day, would you recommend I set that up this way? -> Running Outlook Macros on a Schedule

Thanks for your help Diane, I would definitely not figure this out on my own.

 

[Diane Poremsky]

You can try this - the big issue is when you have a lot of folders to watch, Outlook might forget. Another macro (will need to write it) can run the MoveDoneMessages on any folder - so if the auto ones fail, you can still move them.

Private WithEvents OInbox As Outlook.Folder
Private WithEvents fldDone As Outlook.Folder

Public WithEvents OlItems As Outlook.Items
Public WithEvents olProcess As Outlook.Items
Public WithEvents olFollowUp As Outlook.Items
Public WithEvents olCCMail As Outlook.Items
Public WithEvents olOnHold As Outlook.Items


Public Sub Initialize_handler()

Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")

Set OInbox = NS.GetDefaultFolder(olFolderInbox)

Set OlItems = OInbox.Items
Set fldDone = OInbox.Folders("Finished")

  'subfolders of inbox
  Set olProcess = OInbox.Folders("Processing").Items
  Set olFollowUp = OInbox.Folders("Follow Up").Items
  Set olCCMail = OInbox.Folders("CC Mail").Items
  Set olOnHold = OInbox.Folders("On hold").Items
   
End Sub

Private Sub OlItems_ItemChange(ByVal Item As Object)
  MoveDoneMessages Item
End Sub

Private Sub olProcess_ItemChange(ByVal Item As Object)
  MoveDoneMessages Item
End Sub
   
Private Sub olFollowUp_ItemChange(ByVal Item As Object)
    MoveDoneMessages Item
End Sub

Private Sub olCCMail_ItemChange(ByVal Item As Object)
  MoveDoneMessages Item
End Sub

Private Sub olOnHold_ItemChange(ByVal Item As Object)
  MoveDoneMessages Item
End Sub


Private Sub MoveDoneMessages(ByVal Item As Object)
If Item.Categories = "Done" Then
Item.Move fldDone
End If
End Sub

 

[sophievldn]

Hi Diane, the issue that Outlook will forget, is that in case I set it up to run once a day? I'm not really following. Could you clarify?

I tried this macro but changed the folder names to match the exact folders in my Outlook + changed the if category is done to if flagstatus is complete because it's the emails that are flagged as complete that should be moved. I'm not sure I did this correctly. I thought so, but it's not working... I put it in ThisOutlookSession and ran it but nothing happened. Could you possibly check if something is wrong?

Thank you so much for your help, I really appreciate it.

Private WithEvents OInbox As Outlook.Folder
Private WithEvents fldDone As Outlook.Folder

Public WithEvents OlItems As Outlook.Items
Public WithEvents olProcess As Outlook.Items
Public WithEvents olFollowUp As Outlook.Items
Public WithEvents olCCMail As Outlook.Items
Public WithEvents olOnHold As Outlook.Items


Public Sub Initialize_handler()

Dim NS As Outlook.NameSpace
Set NS = Application.GetNamespace("MAPI")

Set OInbox = NS.GetDefaultFolder(olFolderInbox)

Set OlItems = OInbox.Items
Set fldDone = OInbox.Folders("08 DONE")

'subfolders of inbox
Set olProcess = OInbox.Folders("02 PROCESSING ST").Items
Set olFollowUp = OInbox.Folders("06 FOLLOW UP").Items
Set olCCMail = OInbox.Folders("03 CC MAIL").Items
Set olOnHold = OInbox.Folders("04 ON HOLD ST").Items

End Sub

Private Sub OlItems_ItemChange(ByVal Item As Object)
MoveDoneMessages Item
End Sub

Private Sub olProcess_ItemChange(ByVal Item As Object)
MoveDoneMessages Item
End Sub

Private Sub olFollowUp_ItemChange(ByVal Item As Object)
MoveDoneMessages Item
End Sub

Private Sub olCCMail_ItemChange(ByVal Item As Object)
MoveDoneMessages Item
End Sub

Private Sub olOnHold_ItemChange(ByVal Item As Object)
MoveDoneMessages Item
End Sub


Private Sub MoveDoneMessages(ByVal Item As Object)
If Item.FlagStatus = olFlagComplete Then
Item.Move fldDone
End If
End Sub

 

[Diane Poremsky]

Oh, I thought you were assigning a category - not flagging complete.

change the macro to this - if you want to change the name, use find and replace to update it in all of the itemchange macros.

Private Sub MoveDoneMessages(ByVal Item As Object)

If Item.FlagStatus = olFlagComplete Then
Item.Move fldDone
End If

End Sub