Outlook, konudaki 6 basamaklı sayıyı temel alarak klasöre gitmek için e-postada VBA komut dosyasını çalıştırın

Şirketimiz projelerimizde 6 basamaklı bir rakam kullanıyor. Bu 6 basamaklı numara için e-posta konusunu arayacak bir komut dosyası oluşturmaya çalışıyorum, ardından bu 6 basamaklı sayı ile başlayan alt klasörü bulup e-postayı bu klasöre taşıyacağım.

Bunun nasıl yapılacağıma dair aramalarımda bazı kodlar çaldım ve aşağıdakileri gördüm. Bazı MsgBox komutlarını, işlerin yolunda yürüdüğünü anlamaya çalışmak için koydum. Ancak kodu çalıştırdığımda (Kurallar> Kuralları ve Uyarıları Yönet> Kuralları Şimdi Çalıştır) Bir hata almıyorum ve herhangi bir MsgBox mesajı alamıyorum. Herhangi birinin yanlış yaptığım hakkında herhangi bir fikri olan var mı?

Sub filterbyprojectnumber(Item As Outlook.MailItem)
    Dim nsOutlook As Outlook.NameSpace
    Dim MailDest As Outlook.Folder
    Set nsOutlook = Application.GetNamespace("MAPI")
    Set RegExp = CreateObject("VBScript.RegExp")
    MsgBox Item.Subject
    RegExp.Global = True
    RegExp.Pattern = "([^\d]|^)\d{6}([^\d]|$)"
    If RegExp.Test(Item.Subject) Then
        MsgBox Item.Subject
        MailDest = FindInFolders(Application.Session.Folders, RegExp.Test(Item.Subject))
        MsgBox MailDest
        Item.Move MailDest
    End If
End Sub

Function FindInFolders(TheFolders As Outlook.Folder, Name As String)
  Dim SubFolder As Outlook.MAPIFolder

  On Error Resume Next

  Set FindInFolders = Nothing

  For Each SubFolder In TheFolders
    If LCase(SubFolder.Name) Like LCase(Name) Then
      Set FindInFolders = SubFolder
      Exit For
    Else
      Set FindInFolders = FindInFolders(SubFolder.Folders, Name)
      If Not FindInFolders Is Nothing Then Exit For
    End If
  Next
End Function