Move different sender emails to different folders-CodePudding

Please refer to below codes- I want to move different sender emails to different different folders in outlooks, in my excel Range a1:a3 i have sender names, i will add folder names in range b1:b3, so i want that each sender email to move into respective folder by reffering to excel range please help.

Sub MoveItems()
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object

Set myNameSpace = Outlook.Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items


Set myDestFolder = myInbox.Folders("meetings")

Dim varSearchTerms As Variant
varSearchTerms = Range("a1:a3").Value 'refering to excel range for sender names

Dim varSearchTerm As Variant
For Each varSearchTerm In varSearchTerms

Set myItem = myItems.Find("[SenderName] = '" & varSearchTerm & "'")
    While TypeName(myItem) <> "Nothing"
        myItem.Move myDestFolder
        Set myItem = myItems.FindNext
    Wend
    Next

End Sub

CodePudding user response：

All your emails are put to the same folder - a subfolder of the Inbox folder called meetings. As far as I understand from the description you need to put emails from a specific sender to a separate folder specified in the worksheet as well. To get that job implemented you need to get the target folder name for the sender in the loop and then move all items from that sender to folder specified. The code may look in the following way:

  Dim varSearchTerm As Variant
  For Each varSearchTerm In varSearchTerms
   
    // here you need to get the folder name for the sender name in `varSearchTerm`
    Set myItem = myItems.Find("[SenderName] = '" & varSearchTerm & "'")
    While TypeName(myItem) <> "Nothing"
        
        // and now you move items to the folder retrieved earlier per sender
        myItem.Move senderFolderName
        
        Set myItem = myItems.FindNext
    Wend
  Next

CodePudding user response：

i got this code from stackoverflow but this code refers to subject of the email to move it to respective folder,instead i want it to use sender name , i tried to modified it but i failed... i need your help experts !!!

Option Explicit
Public Sub MoveEmailsToFolders()
    'arr will be a 2D array sitting in an Excel file, 1st col=subject, 2nd col=folder name
    '   // Declare your Variables
    Dim i As Long
    Dim rowCount As Integer
    Dim strSubjec As String
    Dim strFolder As String

    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim myFolder As Outlook.Folder
    Dim Item As Object

    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder

    Dim lngCount As Long
    Dim Items As Outlook.Items
    Dim arr() As Variant 'store Excel table as an array for faster iterations
    Dim WS As Worksheet

    'On Error GoTo MsgErr

    'Set Excel references
    Set WS = ActiveSheet
    If WS.ListObjects.Count = 0 Then
        MsgBox "Activesheet did not have the Excel table containing Subjects and Outlook Folder Names", vbCritical, "Error"
        Exit Sub
    Else
    
    
        arr = WS.ListObjects(1).DataBodyRange
        rowCount = UBound(arr, 2)
        If rowCount = 0 Then
            MsgBox "Excel table does not have rows.", vbCritical, "Error"
            Exit Sub
        End If
    End If


    'Set Outlook Inbox Reference
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set myFolder = olNs.GetDefaultFolder(olFolderInbox)

    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items

      '   // Loop through the Items in the folder backwards
      For lngCount = Items.Count To 1 Step -1
        strFolder = ""
        Set Item = Items.Item(lngCount)

        'Debug.Print Item.Subject

        If Item.Class = olMail Then
            'Determine whether subject is among the subjects in the Excel table
            For i = 1 To rowCount
                If arr(i, 1) = Item.Subject Then
                    strFolder = arr(i, 2)

                    '// Set SubFolder of Inbox, read the appropriate folder name from table in Excel
                    Set SubFolder = Inbox.Folders(strFolder)
                    '// Mark As Read
                    Item.UnRead = False
                    '// Move Mail Item to sub Folder
                    Item.Move SubFolder
                    Exit For
                    End If
                Next i
            End If

      Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
      Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing

    Exit Sub

 '// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
  Resume MsgErr_Exit
End Sub