Consulting

Results 1 to 7 of 7

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

  1. #1

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

    Picture1.jpg


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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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:
    Screenshot 2021-05-11 073040.jpg

  4. #4
    Which line is highlighted?
    Did you copy ALL of the code into a new module?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

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

    This is what is highlighted

    Screenshot 2021-05-12 092907.jpg

  6. #6
    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.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •