Move Mail from Sender to Sender's Folder Name

Question

I want to move messages from the sender to the folder I created for the sender.

The SenderName is displayed as "Doe, John (US)" and my folder would be "Doe, John".

What do I need to do to compare the SenderName to a subfolder name that is two levels below "Inbox". I.e. Inbox→Folder1→"Doe, John".

Public Sub MoveToFolder()
Dim objOutlook As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object

Dim objSubfolder As Outlook.Folder
Dim olsubFolder As Outlook.Folder

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim Msg As Outlook.MailItem

Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer

Set objOutlook = Application
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")

Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("Inbox")
Set colFolders = objParentFolder.Folders

For Each obj In Selection
    Set objVariant = obj

    Dim sfName As Object
    Set sfName = Left(objVariant.senderName, Len(objVariant.senderName) - 5)

    If objVariant.Class = olMail Then

        On Error Resume Next
        ' Use These lines if the destination folder
        '  is not a subfolder of the current folder
        For Each objSubfolder In colFolders
            For Each olsubFolder In objSubfolder
                If olsubFolder.Name = sfName Then
                    Set objDestFolder = objSubfolder
                    MsgBox "Ductus Exemplo"
                    'objVariant.Move objDestFolder
                    'count the # of items moved
                    lngMovedItems = lngMovedItems + 1
                     'Display the number of items that were moved.
                    MsgBox "Moved " & lngMovedItems & " messages(s) from  " & _
                    sfName & "to " & objDestFolder
                Else
                    If objDestFolder Is Nothing Then
                        MsgBox "No Folder Found for " & sfName
                        'Set objDestFolder = objSourceFolder.Folders.Add(sfName)
                        Exit Sub
                    End If

            Next
        Next
    Next
End If
End Sub

Answer 1

Assumptions

• The sender subfolders will be two levels below inbox but not under a single parent folder (i.e. "Doe, John" could appear under Folder1 and "Doe, Jane" under Folder2)
• All emails that should be processed by the macro will be selected before executing it
• The code should not create subfolders for missing senders - as there are multiple possible "parent" folders - but should output a message containing a list of missing sender folders

Conditions that trigger the end of a sender name:

• A hyphen following or preceding a space (i.e. "Doe, John - US" = "Doe, John" and "Huntington-Whiteley, Rosie - CAN" = Huntington-Whiteley, Rosie")
• The second instance of a comma (i.e. "Doe, John, CPA" = "Doe, John")
• The second instance of a space (i.e. "Doe, John Q" = "Doe, John")
• An apostrophe preceded or followed by a space (i.e. "O'Leary, John" = "O'Leary, John" but "Doe, John 'US'" = "Doe, John")
• Any other non-alphabetical character (i.e. "Doe, John: US" = "Doe, John"

---

Proposed Solution

This code will satisfy all of the above conditions, and will output a single message at the end denoting any senders for whom folders could not be found (as opposed to a separate message for each email). It has been tested on Outlook 2013/Windows 10.

Public Sub MoveToFolder()

Dim objSelection As Selection
Set objSelection = Application.ActiveExplorer.Selection

Dim iSelected As Integer, iMoved As Integer
iSelected = objSelection.Count 'Get a total for output message

Dim StrOutput As String, StrUnmoved As String, StrName As String
StrUnmoved = "Unmoved Item Count by Sender" & vbNewLine & "============================"

Dim objNS As NameSpace
Dim objParentFolder As Folder, objSubFolder As Folder, objDestFolder As Folder
Dim BFound As Boolean, iLoc As Integer
Set objNS = Application.GetNamespace("MAPI")
Set objParentFolder = objNS.GetDefaultFolder(olFolderInbox)

'Only execute code if the parent folder has subfolders
If objParentFolder.Folders.Count > 0 Then
    'Loop through all selected items
    For Each Item In objSelection
        If Item.Class = 43 Then
            'This is an email.
            BFound = False
            StrName = GetSenderName(Item.SenderName)
            For Each objSubFolder In objParentFolder.Folders
                If objSubFolder.Folders.Count > 0 Then
                    On Error Resume Next
                    Set objDestFolder = Nothing
                    Set objDestFolder = objSubFolder.Folders(StrName)
                    On Error GoTo 0
                    If Not objDestFolder Is Nothing Then
                        'Folder found.
                        Item.Move objDestFolder
                        iMoved = iMoved + 1
                        BFound = True
                        Exit For
                    End If
                End If
            Next
            If Not BFound Then
                'Sender folder not found. Check if we have already logged this sender.
                iLoc = 0
                iLoc = InStr(1, StrUnmoved, StrName)
                If iLoc > 0 Then
                    'Existing sender name. Increment current total.
                    StrUnmoved = Left(StrUnmoved, iLoc + Len(StrName) + 1) & _
                    Format(CInt(Mid(StrUnmoved, iLoc + Len(StrName) + 2, 5)) + 1, "00000") & Right(StrUnmoved, Len(StrUnmoved) - iLoc - Len(StrName) - 6)
                Else
                    'New sender name.
                    StrUnmoved = StrUnmoved & vbNewLine & StrName & ": 00001"
                End If
            End If
        End If
    Next

    If iMoved = iSelected Then
        StrOutput = "All " & iSelected & " items moved to appropriate subfolders."
    Else
        'Remove extraneous zeroes
        StrUnmoved = Replace(StrUnmoved, ": 000", ": ")
        StrUnmoved = Replace(StrUnmoved, ": 00", ": ")
        StrUnmoved = Replace(StrUnmoved, ": 0", ": ")
        StrOutput = iMoved & "/" & iSelected & " items moved to appropriate subfolders; see below for unmoved details." & vbNewLine & vbNewLine & StrUnmoved
    End If
    MsgBox StrOutput
Else
    MsgBox "There are no subfolders to the default inbox. Script will now exit."
End If

End Sub

Function GetSenderName(StrFullSender As String) As String

'Only take action if a non-null string is passed
If Len(StrFullSender) > 1 Then
    StrFullSender = Trim(StrFullSender) 'Trim extraneous spaces
    Dim StrOutput As String
    'Find first case of the end of the name
    Dim iChar As Integer
    Dim iCommaCount As Integer
    Dim iSpaceCount As Integer
    For iChar = 1 To Len(StrFullSender)
        Select Case Asc(Mid(StrFullSender, iChar, 1))
            Case 65 To 90, 97 To 122 '192 to 246, 248 to 255 'Include 192-246 and 248-255 if you will receive emails from senders with accents or other symbols in their names
                'No action necessary - this is a letter
            Case 45, 151 'Hyphen or EM Dash - could be a hyphenated name
                If Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1)) <> _
                    Trim(Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1))) Then Exit For
                    'There is a space on one or both sides of the hyphen. This is a valid stop.
            Case 44
                iCommaCount = iCommaCount + 1
                If iCommaCount > 1 Then Exit For
            Case 32
                iSpaceCount = iSpaceCount + 1
                If iSpaceCount > 1 Then Exit For
            Case 39
                If Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1)) <> _
                    Trim(Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1))) Then Exit For
                    'There is a space on one or both sides of the apostrophe. This is a valid stop.
            Case Else
                Exit For
        End Select
    Next

    StrOutput = Trim(Left(StrFullSender, iChar - 1))

    GetSenderName = StrOutput
End If

End Function