Déplacer un e-mail d'une boîte de réception partagée vers un sous-dossier

J'essaie de déplacer certains e-mails qui arrivent dans notre boîte de réception partagée (ABC COMPANY) vers un sous-dossier (A&D) créé dans un dossier principal (DAILY INFO). Je n'ai trouvé que sur le Web, une macro qui déplace les e-mails de la boîte de réception partagée vers le dossier principal, mais pas dans le sous-dossier. Voici le code que j'ai trouvé.

 Dim NS As NameSpace

 Dim sharedInbox As folder

 Dim sharedDestinationFolder As folder

 Dim sharedItems As Selection

 Dim i As Long

    Set NS = Application.GetNamespace("MAPI")
    Set sharedInbox = NS.Folders("ABC COMPANY").Folders("Inbox")
    Set sharedDestinationFolder = sharedInbox.Folders("DAILY INFO")

    Set sharedItems = ActiveExplorer.Selection

   ' Counting in reverse
    'when changing the number of items in a collection
    For i = sharedItems.Count To 1 Step -1
        sharedItems(i).Move sharedDestinationFolder
    Next i

ExitRoutine:
    Set NS = Nothing
    Set sharedItems = Nothing
    Set sharedInbox = Nothing
    Set sharedDestinationFolder = Nothing


End Sub