Moving of mails from specific sender to specific folder via excel

[hemanttt]

Hello all, I have this code, refers to subject of the email from excel A column to move it to respective outlook Subfolder named in B column, but instead of subject 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