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

Hello,

I work with a team and we all share a mailbox. This mailbox gets dozens of emails per day and we file them based on the ref# and the client name in the subject line. I am looking to create a macro that looks for the ref# and the client name in the subject line and files the email in the client subfolder and then with the corresponding ref#. I also need to the macro to create a subfolder if the ref# subfolder doesn't exist yet.

Here is what the inbox looks like (where Aqua-Net, Micr0soft, Ph1lipps and S0ny are the clients and the numbers 20345, 20389, etc are the ref#s):

Attachment 28442


The subject lines look like this:

Ref#20345 - Aqua-Net - Customer Satisfaction Email - FR

RE: Ref#20389 - Micr0soft - 2021 User Guide - FR

Ref#20547 - Ph1lipps - Website proofing - FR (this would be an example of where the macro would create the subfolder)

etc.


thank you!!!!

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.

Code:

---

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

---

Thank you so much for replying! When i try to run the macro, i get the error below.
I would also like to know how to update the macro to automatically run on the folder. We have created a subfolder in the shared inbox called _TO FILE so we will be manually moving all emails that need to be filed into this folder and we want the macro to automatically file the email in the correct folder from there.

Here is the error i get now:
Attachment 28445

Which line is highlighted?
Did you copy ALL of the code into a new module?

Yes, i copied all of the code into a new module.

This is what is highlighted

Attachment 28450

It seems likely that you have a missing DLL. Which items do you have checked in VBA editor Tools > References? Ensure that you have Microsoft Forms 2 Object Library and Microsoft Scripting Runtime checked.

Hi there,

I have those checked and I have the same problem. maybe i'm not inserting the code properly. Can you please send me the steps?

thank you