Macro to move emails from a folder into another folder based on Subject line

[gmayor]

The following based on code I have posted before assumes that client names may have a hyphen (which complicates things). It creates the folders if missing and moves the item to the appropriate folder.
The script MoveToClientFolder could be run from a rule to process messages as they arrive.

Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 11 May 2021

Sub TestMacro()
'select a messageand run the process
Dim olMsg As MailItem
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olMsg = ActiveInspector.currentItem
        Case olExplorer
            Set olMsg = Application.ActiveExplorer.Selection.Item(1)
    End Select
    MoveToClientFolder olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub MoveToClientFolder(olItem As MailItem)
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.Folder
Dim sClient As String, sRef As String
Dim vSubject As Variant

    If TypeName(olItem) = "MailItem" Then
        Set olNS = GetNamespace("MAPI")
        vSubject = Split(olItem.Subject, "-")

        'Get the client name
        Select Case UBound(vSubject)
            Case Is = 3
                sClient = Trim(vSubject(1))
            Case Is = 4
                sClient = Trim(vSubject(1)) & "-" & Trim(vSubject(2))
            Case Else
                Beep
                GoTo lbl_Exit
        End Select

        'get the ref number
        If InStr(1, CStr(vSubject(0)), "Ref#") = 0 Then
            Beep
            GoTo lbl_Exit
        End If
        sRef = GetNum(CStr(vSubject(0)))
        'create the client folder, if missing
        AddOutlookFolder sClient
        'create the REFnumber folder if missing
        AddRefFolder sClient, sRef

        Set olFolder = olNS.GetDefaultFolder(6).folders(sClient).folders(sRef)
        'move the item to the folder
        olItem.Move olFolder
    End If
lbl_Exit:
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olItem = Nothing
    Exit Sub
End Sub

Private Sub AddClientFolder(strFolderName As String)
Dim i As Long
Dim olNS As NameSpace
Dim iFolder As Folder
Dim bExists As Boolean

    Set olNS = GetNamespace("MAPI")
    For i = olNS.GetDefaultFolder(6).folders.Count To 1 Step -1
        Set iFolder = olNS.GetDefaultFolder(6).folders(i)
        If iFolder.Name = strFolderName Then
            bExists = True
            Exit For
        End If
    Next i

    If Not bExists Then
        Set iFolder = olNS.GetDefaultFolder(6)
        iFolder.folders.Add (strFolderName)
    End If

    Set iFolder = Nothing
    Set olNS = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Sub AddRefFolder(strClient As String, strRef As String)
Dim i As Long
Dim olNS As NameSpace
Dim iFolder As Folder
Dim bExists As Boolean

    Set olNS = GetNamespace("MAPI")
    bExists = False
    For i = olNS.GetDefaultFolder(6).folders(strClient).folders.Count To 1 Step -1
        Set iFolder = olNS.GetDefaultFolder(6).folders(strClient).folders(i)
        If iFolder.Name = strRef Then
            bExists = True
            Exit For
        End If
    Next i

    If Not bExists Then
        Set iFolder = olNS.GetDefaultFolder(6).folders(strClient)
        iFolder.folders.Add strRef
    End If

    Set iFolder = Nothing
    Set olNS = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function GetNum(sText As String) As String
Dim i As Integer
    For i = 1 To Len(sText)
        If Mid(sText, i, 1) >= "0" And Mid(sText, i, 1) <= "9" Or Mid(sText, i, 1) = "." Then
            GetNum = GetNum + Mid(sText, i, 1)
        End If
    Next
lbl_Exit:
    Exit Function
End Function