Извлечение определенного строкового формата из темы для сортировки

Мне нужно взять данные из темы писем и использовать их для создания / сортировки писем.

Данные начинаются с цифры 8 и состоят из 6 символов. Иногда ему предшествует заголовок «BU #», «BU» и т. д. Как только я выберу один кейс, я могу скопировать его для других сценариев.

Прямо сейчас я использую ручной макрос для сортировки элементов по папкам и ввода BU. Я хотел бы вытащить данные из темы, чтобы я мог выделить группу писем и запустить макрос, чтобы он сортировал их по папкам BU.

Это то, что у меня есть для ручной сортировки.

Sub MoveToFiled()
    On Error Resume Next

    Dim ns As Outlook.NameSpace
    Dim moveToFolder As Outlook.MAPIFolder
    Dim objItem As Outlook.MailItem
    Dim Myvalue As String
    Dim myFolder As Outlook.folder
    Dim myNewFolder As Outlook.folder
    Set ns = Application.GetNamespace("MAPI")

    Myvalue = InputBox("Enter BU", "Input")

    'Define path to the target folder
    Set myFolder = ns.Folders("Current Projects").Folders("BU")
    Set myNewFolder = myFolder.Folders.Add(Myvalue)
    Set moveToFolder = ns.Folders("Current Projects").Folders("BU").Folders(Myvalue)
    Set Conversations = ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)

    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox ("No item selected")
        Exit Sub
    End If

    If moveToFolder Is Nothing Then
        MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
    End If

    For Each objItem In Application.ActiveExplorer.Selection
        If moveToFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.UnRead = False
                objItem.FlagStatus = olNoFlag
                objItem.Move moveToFolder
                objItem.Categories = ""
                objItem.Save
            End If
        End If
    Next    

    Set objItem = Nothing
    Set moveToFolder = Nothing
    Set ns = Nothing
    Set myFolder = Nothing
End Sub

Для справки это то, что я придумал для рекурсивной функции, которая захватывает BU из объекта, создает папку, перемещает материал ...

Sub MoveToFiledAUTO()
On Error Resume Next

Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim objItem As Object
Dim Myvalue As String
Dim myFolder As Outlook.folder
Dim myNewFolder As Outlook.folder
Set ns = Application.GetNamespace("MAPI")
Dim vSplit As Variant
Dim sWord As Variant
Dim minisplit As Variant
Dim objSelection As Outlook.Selection

Set Conversations = ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)
Set myFolder = ns.Folders("Current Projects").Folders("BU")

If Application.ActiveExplorer.Selection.Count = 0 Then
   MsgBox ("No item selected")
   Exit Sub
End If


Set objSelection = Outlook.Application.ActiveExplorer.Selection

For Each objItem In objSelection
    If TypeOf objItem Is MailItem Then
     subby = objItem.subject
        vSplit = Split(subby)
       For Each sWord In vSplit
                 If Left$(sWord, 1) = "8" And Len(sWord) = 6 Then
                     Myvalue = Left$(sWord, 6)
                     Exit For
                 ElseIf Left$(sWord, 2) = "#8" And Len(sWord) = 7 Then
                    Myvalue = Mid$(sWord, 2, 6)
                    Exit For
                 ElseIf Left$(sWord, 4) = "BU#8" And Len(sWord) = 9 Then
                     Myvalue = Mid$(sWord, 4, 6)
                     Exit For
                 ElseIf Left$(sWord, 3) = "U#8" And Len(sWord) = 8 Then
                     Myvalue = Mid$(sWord, 3, 6)
                     Exit For
                 ElseIf Left$(sWord, 3) = "BU8" And Len(sWord) = 8 Then
                     Myvalue = Mid$(sWord, 3, 6)
                     Exit For
                 ElseIf Left$(sWord, 1) = "8" And Len(sWord) = 7 Then
                     Myvalue = Left$(sWord, 6)
                     Exit For
                 Else
                 End If
         Next
    Set myNewFolder = myFolder.Folders.Add(Myvalue)
    Set moveToFolder = ns.Folders("Current Projects").Folders("BU").Folders(Myvalue)
   If moveToFolder Is Nothing Then
      MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
    End If
   If moveToFolder.DefaultItemType = olMailItem Then
      If objItem.Class = olMail Then
         objItem.UnRead = False
         objItem.FlagStatus = olNoFlag
         objItem.Move moveToFolder
         objItem.Categories = ""
         objItem.Save
      End If
  End If
    End If
Next



Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing
Set myFolder = Nothing
End Sub

Это вытаскивает BU из темы сообщения, создает папку и отправляет почту в архив. Спасибо!