Hi,

Wanna to search the emails in outlook 2007 based upon the data in Excel. Daily I recevies N number of emails and I do export those mails into workbook.

Now what happens is I may get duplicate mails. So, have to check/search/flag the emails in outlook based on Excel, in which it has the old data, columns as From, Subject, Date, etc.

Please anyone's help will be appreciable that makes my work easier and useful with your code.

Please find the below code which I have worked, badly not working..

Sub Promote()

' *********Declare the Objects***************


' Excel Objects used

 Dim ObjExApp As Excel.Application
 Dim ObjExWb As Excel.Workbook
 Dim ObjExWs As Excel.Worksheet
 Dim ExWbPath As String
 Dim ExWb As String
 Dim nrow As Integer
 Dim IncRow As Integer

' Outlook Object Used

 Dim ObjOutApp As New Outlook.Application
 Dim ObjOutItem As Outlook.MailItem
 Dim ObjOutName As Outlook.NameSpace
 Dim ObjOutInbox As Outlook.MAPIFolder
 Dim BdyVar As String
 Dim Search_String As String

' Assign Workbook Path and Name

On Error GoTo Exit_Sub_FileName

ExWb = InputBox("Please Enter the Excel File Name to search the data in outlook", "File Name", "xyz.xlsx")

If ExWb = "" Then
    MsgBox "Sorry, please try Again", vbExclamation, "File Name Error!"
    Exit Sub
End If

ExWbPath = "P:\Desktop\"
ExWb = ExWbPath & ExWb

' Set the Outlook Objects

Set ObjOutApp = CreateObject("Outlook.Application")
Set ObjOutName = ObjOutApp.GetNamespace("MAPI")
Set ObjOutInbox = ObjOutName.GetDefaultFolder(olFolderInbox)

' Set the Excel Objects

Set ObjExApp = CreateObject("Excel.Application")
ObjExApp.Workbooks.Open (ExWb)
Set ObjExWb = ObjExApp.ActiveWorkbook
Set ObjExWs = ObjExWb.Sheets(1)
ObjExWs.Activate

'Check the next Available row in the Worksheet
For nrow = 1 To 32767
  If ObjExWs.Range("B").Value = "" Then Exit For
Next

' If No Emails found come Exit of the Procedure

If ObjOutInbox.Items.count = 0 Then
   MsgBox "Inbox is Empty", vbInformation, "Nothing Found"
   Exit Sub
End If

' ******Code to to Search for particular email and Paste records in Excel Workbook********

'Take User Input and set the Email Search Key word
Search_String = cell.Offset(0, 1).Value
If Search_String = "" Then
    MsgBox "No Key word, please try again", vbExclamation, "Keyword Error!"
    Exit Sub
End If
IncRow = 0

On Error Resume Next
For i = ObjOutInbox.Items.count To 1 Step -1

    If ObjOutInbox.Items(i).Class = olMail Then
    
    Set ObjOutItem = ObjOutInbox.Items.Item(i)
    
        ' Comparision of User Input keyword and Subject
        If (ObjOutItem.Subject Like Search_String) Then
                         
             ' Set Flag color to debug the program
             ObjOutItem.FlagIcon = olBlueFlagIcon
             ObjOutItem.Save
               
          IncRow = IncRow + 1

        End If
    End If
Next
On Error GoTo 0



' Close the workbook
ObjExWb.Save
ObjExWb.Close

' Release the Objects
Set ObjExApp = Nothing
Set ObjExWb = Nothing
Set ObjExWs = Nothing
Set ObjOutName = Nothing
Set ObjOutInbox = Nothing
Set ObjOutItem = Nothing
Set ObjOutApp = Nothing

Exit Sub

 
' On Error Code to Close the running Excel File

Exit_Sub:
    
    MsgBox "Invalid Entry! Please try again.", vbExclamation, "Invalid Search"
    ObjExWb.Save
    ObjExWb.Close
    Exit Sub
        
Exit_Sub_Callfun:

    MsgBox "Unable to get records from body! Please try again.", vbExclamation, "Records Error!"
    ObjExWb.Save
    ObjExWb.Close
    Exit Sub
    
Exit_Sub_FileName:

    MsgBox "Invalid File Name", vbExclamation, "Filename Error!"

End Sub