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

[ashleyh1987]

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):

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!!!!

[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

[ashleyh1987]

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:
28445

[gmayor]

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

[ashleyh1987]

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

This is what is highlighted

28450

[gmayor]

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.

[ashleyh1987]

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