Makro - Automatisches Weiterleiten und Verschieben von Mails

Moin zusammen,

ich habe eine Frage zum automatischen Weiterleiten&Verschieben von Mails per VBA-Makro.

Nochmal das Darzustellende kurz kommentiert: In einem Sammelpostfach treffen Mails eines bestimmten Absenders ein & sollen weitergeleitet und verschoben werden. (Regel bei Eintreffen Mail in Postfach -> Skript ausführen)
Zunächst wird ein Wert aus der Betreffzeile ausgelesen welcher Bestandteil der Mail-Adresse ist, an die die Mail weitergeleitet wird.
Entsprechend wird die Mail weitergeleitet und anschließend soll die Mail in ein Unterordner des Sammelpostfachs verschoben werden.

Habe bereits den Code an meinem "normalen" Postfach getestet - lief einwandfrei (Betreffzeile & Weiterleiten & Verschieben).
Beim Sammelpostfach wird die Betreffzeile zwar "gekürzt", jedoch keine Mails weitergeleitet oder gar verschoben.

Hat da jemand eine Idee? Bin am verzweifeln..
Vielen Dank im Voraus!!!

Sub Test(oMail As Outlook.MailItem)

 Dim objMail_In         As MailItem
 Dim objMail_Out        As MailItem
 Dim Folder             As Outlook.MAPIFolder
 Dim SubFolder          As Outlook.Folder
 Dim TestFolder         As Outlook.Folder
 Dim myOlApp            As Outlook.Application
 Dim FolderName         As String
 Dim Ns                 As Outlook.NameSpace
 Dim myEntryID          As String
 Dim myStoreID          As String
 
 
 FolderName = "Sonstiges"  

'Nummer aus Betreffzeile filtern  
 Dim arr As Variant
 Dim i As Long
  
'Liste der zu entfernenden Begriffe  
 arr = Array("XX", "YY")  
  
 For i = 0 To UBound(arr)
    oMail.Subject = Replace(oMail.Subject, arr(i), "", , , vbTextCompare)  
    Next
    If oMail.Saved = False Then
       oMail.Save
    End If

 Select Case TypeName(Application.ActiveExplorer)
 Case "Explorer"  
 Set myItem = oMail
 Case Else
 End Select

 Set objMail_In = myItem
 Set objMail_Out = myItem.Forward
 Set myOlApp = Outlook.Application
 Set Ns = Application.GetNamespace("MAPI")  
 Set Folder = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders(FolderName)  
        myEntryID = Folder.EntryID
        myStoreID = Folder.StoreID
 Set Folder = Application.Session.Stores("x@y.com").GetRootFolder.Folders("Posteingang").Folders("Sonstiges")  
 
 
 With objMail_Out
 .To = "x" & objMail_In.Subject & "@y.com" 'Empfänger  
 .Subject = "XX" & oMail.Subject & "YY"  
 .Body = "Anbei der Orginalanhang."  
 .Send
 End With
 
 With objMail_In
   .Subject = "XX" & oMail.Subject & "YY"  
   .Move Folder
 End With
 
 End Sub