Outlook VBA move sent mail based on SendAs address

Question

I am trying to move sent mail from my regular Sent Items standard folder to two separate folders in Outlook (365). On the left in my Folder Pane I have my email '[email protected]', 'Online Archive - [email protected]' (an Online Archive for more storage similar to a PST I guess) and then a shared mailbox '[email protected]'.

One of the backup folders is in my Online Archive and the other backup folder is a shared mailbox. Here's the VBA code I have so far. Ideally I would like it to run each time an email is sent/appears in the Sent Items so I think I could use WithEvents somehow but I am okay to run the macro on an as needed basis.

When I run the code none of the mail moves so I think the issue is something with how I am selecting the filtered mail items to move.

Sub MoveItems()

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySource As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set mySource = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myItems = mySource.Items

    Set myDestFolder = Outlook.Session.Folders("Online Archive - [email protected]").Folders("Backup")
    Set myItem = myItems.Find("[SenderEmailAddress] = '[email protected]'")
    
        While TypeName(myItem) <> "Nothing"
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
        Wend
       
    Set myItem = myItems.Find("[SenderEmailAddress] = '[email protected]'")
    Set myDestFolder = Outlook.Session.Folders("[email protected]").Folders("SecondaryBackup")
        
        While TypeName(myItem) <> "Nothing"
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
        Wend

End Sub

Answer 1

Sub MoveItems()

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim mySource, myDestFolder As Outlook.MAPIFolder
Dim myItems As Outlook.Items
Dim myItem As Object
Dim strFilter As String

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set mySource = myNameSpace.GetDefaultFolder(olFolderSentMail)
Set myItems = mySource.Items

strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & Chr(34) & " like '%Main Display Name%'"

    Set myDestFolder = Outlook.Session.Folders("Online Archive - [email protected]").Folders("Backup")
    Set myItem = myItems.Find(strFilter)
    
        While TypeName(myItem) <> "Nothing"
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
        Wend
        
strFilter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & Chr(34) & " like '%Shared Box Display Name%'"

    Set myDestFolder = Outlook.Session.Folders("Shared Box Display Name").Folders("Backup")
    Set myItem = myItems.Find(strFilter)
    
        While TypeName(myItem) <> "Nothing"
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
        Wend

End Sub