Thread: Search and Flag the Emails in Outlook based on the Data in Excel (Subject column)

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

Can you provide a sample of the data in Excel?

Hi Domenic,


Example.xlsx


Please find the attached with example data, in which by using the subject coulmn I have to search/flag the emails in outlook..

Eagerly waiting, Domenic...

Actually, now that I've given it some more thought, I think there may be a couple of problems with the way you're trying to do it. The first problem is that the dates contained in your workbook do not include the time. Whereas the code returns both the date and time (including seconds) from an email. As a result, we wouldn't be able to use date and time as a unique identifier. Then, if I'm not mistaken, the second problem is that even when two emails are duplicates, the time received can differ. See if the following helps...

http://www.planet-source-code.com/vb...40372&lngWId=1

Hi Domenic,

Thanks for the code, but as per my view that I have to find the emails based upon the Excel data. There is no matter that the date is not a concern. Based on the Subject column in Excel, have to find/track the emails in outlook..


Is there any posibility of the code? Please help me out in finding the solution to this problem..

Hope, you will guide me and sure will wait for the reply..

Assumptions:

1) The sheet containing the data is the active sheet.

2) Column A contains "From", and Column B contains "Subject"


Notes:

1) For each name in Column A, the macro searches and flags all emails with the same name and corresponding subject.

2) The search in matching both the name and subject is case-sensitive.

3) A reference needs to be set by selecting 'Tools > References > Microsoft Outlook xx.x Object Library'.


Code:

Option Explicit

Sub Promote()

    Dim OL As Outlook.Application
    Dim NS As Outlook.Namespace
    Dim MItems As Outlook.Items
    Dim MItem As Outlook.MailItem
    Dim strName As String
    Dim strSubject As String
    Dim i As Long
    Dim LastRow As Long
    
    Set OL = CreateObject("Outlook.Application")
    
    Set NS = OL.GetNamespace("MAPI")
    
    Set MItems = NS.GetDefaultFolder(olFolderInbox).Items
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To LastRow
        strName = Cells(i, "A").Value
        strSubject = Cells(i, "B").Value
        Set MItem = MItems.Find("[From] = " & strName)
        While TypeName(MItem) <> "Nothing"
            If MItem.Subject = strSubject Then
                MItem.FlagIcon = olBlueFlagIcon
                MItem.Save
            End If
            Set MItem = MItems.FindNext
        Wend
    Next i
    
End Sub

Hi Domenic,

Really I'm glad for you code, but here I'm getting an Error as

Run-time error '-2147352567 (80020009)':

Cannot parse condition. Error at ",".


at line
Set MItem = MItems.Find("[From] = " & strName)

Could you please suggest me..

It works for me on Excel 2010. Try replacing...

Set MItem = MItems.Find("[From] = " & strName)

with

Set MItem = MItems.Find("[From] = " & Chr(34) & strName & Chr(34))

Hi Domenic,

Thanks for the code. It's working..!!!! great..

Thanks,
Chaitanya

You're very welcome! Thanks for the feedback!