Pulling specific string format from subject for sorting

Question

I need to take data from the subject line of emails and use that to create/sort the emails.

The data starts with an 8 and has 6 characters. Sometimes it is preceded by its title "BU#", "BU", etc. Once I get one case down I can copy it for the other scenarios.

Right now I use a manual macro to sort the items into folders and type in the BU. I'd like to pull the data out of the subject so I can highlight a group of emails and run the macro, so it sorts them into BU folders.

This is what I have working for manual sorting.

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

---

Per help this is what I came up with for a recursive function that grabs the BU from the subject, creates the folder, moves the stuff--

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

This pulls out the BU from the message subject, creates the folder, and files the mail away. Thank you!

Answer 1

This should get you started:

Public Function GetBUNumber(sSubject As String) As String
  Dim vSplit As Variant
  Dim sWord As Variant

  vSplit = Split(sSubject, " ")
  For Each sWord In vSplit
    If IsNumeric(sWord) Then
      If Left$(sWord, 1) = "8" And Len(sWord) = 6 Then
        GetBUNumber = sWord
        Exit Function
      End If
    End If
  Next
  GetBUNumber = "Not Found"

End Function

You can then call that function using your Myvalue like this:

Dim sFound as String
sFound = GetBUNumber(Myvalue)

It will either return the 6 digit number that starts with 8 or "Not Found".

Edit: Looks like you need a bit more instruction

Change this line in your code:

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

to this

Myvalue = GetBUNumber(InputBox("Enter BU", "Input"))
If Myvalue = "Not Found" Then
  MsgBox "BU Number not found."
  Exit Sub
End If