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
