Compare Emails

[parth007]

If we have Inbox email data in Excel sheet1 & Sentitem data in sheet2,
How will be be able to track the rows which are in inbox sheet & not yet replied in sentitems?
Any email tracker available for this?

VBA code

[gmayor]

This is nothing to do with Outlook. It's an Excel issue. Use the forum search function for 'Compare Worksheets', where you will find several examples to set you on your way.

[parth007]

Thanks Graham... I will surely do..
But there must be a VBA code which is accordance to Outlook only for letting us know which inbox mails are not yet replied..

[gmayor]

Indeed, but that is not what you asked for. If you want to check which messages have not been replied to then the following should establish that.

Sub IsReplied()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim objItem As Outlook.MailItem
Const PropName As String = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
    For i = Session.GetDefaultFolder(olFolderInbox).folders.Count To 1 Step -1
        Set iFolder = Session.GetDefaultFolder(olFolderInbox).folders(i)
        For Each olItem In iFolder.Items
            If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
                'no reply sent and message not forwarded so
                'Do something with olitem here
            End If
        Next olItem
        For j = iFolder.folders.Count To 1 Step -1
            Set subFolder = iFolder.folders(j)
            For Each olItem In subFolder.Items
                If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
                    'no reply sent and message not forwarded so
                    'Do something with olitem here
                End If
            Next olItem
        Next j
    Next i
CleanUp:
    Set olItem = Nothing
    Set olItems = Nothing
    Set objItem = Nothing
lbl_Exit:
    Exit Sub
End Sub

[parth007]

Hi Graham, i am just a beginner in VBA outlook..
what to write instead of

'no reply sent and message not forwarded so
'Do something with olitem here
?
What will be the VBA code just to paste data on each row instead of above comments

[parth007]

I Got code to do something with olitem but after running this macro..
it only returns one row as output..
not all unreplied data..
coz i am not aware how to make it paste rows in excel one after the other in loop...

[gmayor]

It doesn't do anything because you have not said what you wanted it to do. The macro merely provides a means to identify the messages in the inbox and its sub folders that have not been replied to or forwarded. It does not do anything with those messages.

You keep referring to 'rows' and Excel, but this forum is for Outlook and the code quoted is Outlook code. There is no automatic correlation between Outlook data and Excel.

Initially you said you have a workbook in which you recorded inbox and sent data and asked how to compare them. Then you said you wanted to establish which messages in Inbox had not been replied to. Now we are back with Excel again.

Tell us what you want to do with the information and we can probably tell you how to do it. What is the Excel workbook in which you wish to record the fact? What is the name of the sheet in which you want to record it. What data from the message do you want to record?

[parth007]

Hi Graham,

Basically i was looking for VBA code which will give me the emails which are not responded.
But i could not find the way out..
But considering it as a Excel part..
Sheet1 have Inbox data & sheet 2 have sentitem data

I somehow managed to get the below details in both sheets

SenderName
To
Subject
ReceivedTime
LastModificationTime
Categories
Unread
FlagRequest

Any full proof VBA code which will actually help me highlight those emails which are not responded on the basis of the above columns details? highlighting rows in Sheet1(Inbox data)

Whats the correct columns & logic to match up.. i am still puzzled..

[gmayor]

You are not the only one who is puzzled.

Do you already have the received and sent messages in the worksheet? In which case my first response is the way forward. i.e. an Excel macro or function to compare the worksheets.
If the messages are in Outlook folders and not in the worksheets, but you require them there, then you will need the following modificationtro the code. This will create a workbook with sheet 1 containing a log of the messages that haven't been replied to and sheet2 a log of those that have. You need to change the path to a location on your harddrive.

Sub IsReplied()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim objItem As Outlook.MailItem
Dim iFolder As Folder
Dim xlApp As Object
Dim xlWB As Object
Dim xlInSheet As Object
Dim xlOutSheet As Object
Dim i As Long
Dim iNextInRow As Long, iNextOutRow As Long
Dim strWorkbookPath As String
Dim strWorkbook As String
Const PropName As String = "http://schemas.microsoft.com/mapi/proptag/0x10810003"

    strWorkbookPath = "C:\Path\" 'path to save workbook must exist
    strWorkbook = strWorkbookPath & Format(Date, "YYYY") & "_MessageLog.xlsx"

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    'On Error GoTo 0
    xlApp.Visible = True
    'Open the workbook to input the data
    If Not FileExists(strWorkbook) Then
        Set xlWB = xlApp.Workbooks.Add
        With xlWB.sheets(1)
            .Range("A1") = "SENDERNAME"
            .Range("B1") = "TO"
            .Range("C1") = "SUBJECT"
            .Range("D1") = "RECEIVEDTIME"
            .Range("E1") = "LASTMODIFICATIONTIME"
            .Range("F1") = "CATEGORIES"
            .Range("G1") = "UNREAD"
            .Range("H1") = "FLAGREQUEST"
        End With
        With xlWB.sheets(2)
            .Range("A1") = "SENDERNAME"
            .Range("B1") = "TO"
            .Range("C1") = "SUBJECT"
            .Range("D1") = "RECEIVEDTIME"
            .Range("E1") = "LASTMODIFICATIONTIME"
            .Range("F1") = "CATEGORIES"
            .Range("G1") = "UNREAD"
            .Range("H1") = "FLAGREQUEST"
        End With
        xlWB.SaveAs Filename:=strWorkbook
    Else
        Set xlWB = xlApp.Workbooks.Open(strWorkbook)
    End If

    Set xlInSheet = xlWB.sheets("Sheet1")
    Set xlOutSheet = xlWB.sheets("Sheet2")


    'For i = Session.GetDefaultFolder(olFolderInbox).folders.Count To 1 Step -1 'Include sub folders
        Set iFolder = Session.GetDefaultFolder(olFolderInbox) '.folders(') 'add to include sub folders
        
        For Each olItem In iFolder.Items
            If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
                With xlInSheet
                    iNextInRow = xlInSheet.Range("A" & xlInSheet.Rows.Count).End(-4162).Row + 1
                    .Range("A" & iNextInRow) = olItem.Sender
                    .Range("B" & iNextInRow) = olItem.To
                    .Range("C" & iNextInRow) = olItem.Subject
                    .Range("D" & iNextInRow) = olItem.ReceivedTime
                    .Range("E" & iNextInRow) = olItem.LastModificationTime
                    .Range("F" & iNextInRow) = olItem.Categories
                    .Range("G" & iNextInRow) = olItem.UnRead
                    .Range("H" & iNextInRow) = olItem.FlagRequest
                End With
            Else
                iNextOutRow = xlOutSheet.Range("A" & xlOutSheet.Rows.Count).End(-4162).Row + 1
                With xlOutSheet
                    .Range("A" & iNextOutRow) = olItem.Sender
                    .Range("B" & iNextOutRow) = olItem.To
                    .Range("C" & iNextOutRow) = olItem.Subject
                    .Range("D" & iNextOutRow) = olItem.ReceivedTime
                    .Range("E" & iNextOutRow) = olItem.LastModificationTime
                    .Range("F" & iNextOutRow) = olItem.Categories
                    .Range("G" & iNextOutRow) = olItem.UnRead
                    .Range("H" & iNextOutRow) = olItem.FlagRequest
                End With
            End If
        Next olItem
    'Next i 'include subfolders
CleanUp:
    Set olItem = Nothing
    Set olItems = Nothing
    Set objItem = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlInSheet = Nothing
    Set xlOutSheet = Nothing
lbl_Exit:
    Exit Sub
End Sub

[parth007]

Hi Graham,

Thanks for it, Yes i already have the INbox & sentitems data in workbook (Sheet1 & Sheet2) i have a code which helps me to download both inbox & sentitem data within a specified date range..

While running this code in a module.. i am getting nelow error on FileExists
"Sub or Function Notdefined"

[parth007]

I COmmented the IF FileExists function.. IF else & Endif i commented it executed successfully..
But it displayed data till january..
Cant we have something which will prompt for dates??
Like the user will decide the start date & end date for email fetch?

[parth007]

Below is the code i modified for storing the file.. slight file name change & auto save..
Can we have an option that while running this macro it will ask for start date & end date first before downloading the data on to the sheets?

Sub IsReplied()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim objItem As Outlook.MailItem
Dim iFolder As Folder
Dim xlApp As Object
Dim xlWB As Object
Dim xlInSheet As Object
Dim xlOutSheet As Object
Dim i As Long
Dim iNextInRow As Long, iNextOutRow As Long
Dim strWorkbookPath As String
Dim strWorkbook As String
Const PropName As String = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
    strWorkbookPath = "C:\Testing\UnrespondedEmails_" 'path to save workbook must exist
    strWorkbook = strWorkbookPath & Format(Now(), "DD-MM-YYYY hh mm ss AMPM") & "_MessageLog.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    'On Error GoTo 0
    xlApp.Visible = True
    'Open the workbook to input the data
   ' If Not FileExists(strWorkbook) Then
        Set xlWB = xlApp.Workbooks.Add
        With xlWB.Sheets(1)
            .Range("A1") = "SENDERNAME"
            .Range("B1") = "TO"
            .Range("C1") = "SUBJECT"
            .Range("D1") = "RECEIVEDTIME"
            .Range("E1") = "LASTMODIFICATIONTIME"
            .Range("F1") = "CATEGORIES"
            .Range("G1") = "UNREAD"
            .Range("H1") = "FLAGREQUEST"
        End With
        With xlWB.Sheets(2)
            .Range("A1") = "SENDERNAME"
            .Range("B1") = "TO"
            .Range("C1") = "SUBJECT"
            .Range("D1") = "RECEIVEDTIME"
            .Range("E1") = "LASTMODIFICATIONTIME"
            .Range("F1") = "CATEGORIES"
            .Range("G1") = "UNREAD"
            .Range("H1") = "FLAGREQUEST"
        End With
        xlWB.SaveAs Filename:=strWorkbook
    'Else
        Set xlWB = xlApp.Workbooks.Open(strWorkbook)
    'End If
    Set xlInSheet = xlWB.Sheets("Sheet1")
    Set xlOutSheet = xlWB.Sheets("Sheet2")

    'For i = Session.GetDefaultFolder(olFolderInbox).folders.Count To 1 Step -1 'Include sub folders
        Set iFolder = Session.GetDefaultFolder(olFolderInbox) '.folders(') 'add to include sub folders
        
        For Each olItem In iFolder.Items
            If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
                With xlInSheet
                    iNextInRow = xlInSheet.Range("A" & xlInSheet.Rows.Count).End(-4162).Row + 1
                    .Range("A" & iNextInRow) = olItem.Sender
                    .Range("B" & iNextInRow) = olItem.To
                    .Range("C" & iNextInRow) = olItem.Subject
                    .Range("D" & iNextInRow) = olItem.ReceivedTime
                    .Range("E" & iNextInRow) = olItem.LastModificationTime
                    .Range("F" & iNextInRow) = olItem.Categories
                    .Range("G" & iNextInRow) = olItem.UnRead
                    .Range("H" & iNextInRow) = olItem.FlagRequest
                End With
            Else
                iNextOutRow = xlOutSheet.Range("A" & xlOutSheet.Rows.Count).End(-4162).Row + 1
                With xlOutSheet
                    .Range("A" & iNextOutRow) = olItem.Sender
                    .Range("B" & iNextOutRow) = olItem.To
                    .Range("C" & iNextOutRow) = olItem.Subject
                    .Range("D" & iNextOutRow) = olItem.ReceivedTime
                    .Range("E" & iNextOutRow) = olItem.LastModificationTime
                    .Range("F" & iNextOutRow) = olItem.Categories
                    .Range("G" & iNextOutRow) = olItem.UnRead
                    .Range("H" & iNextOutRow) = olItem.FlagRequest
                End With
            End If
        Next olItem
    'Next i 'include subfolders
    Windows(xlWB).Activate
    ActiveWorkbook.Save ' 
    ActiveWorkbook.Close
CleanUp:
    Set olItem = Nothing
    Set olItems = Nothing
    Set objItem = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlInSheet = Nothing
    Set xlOutSheet = Nothing
lbl_Exit:
    Exit Sub
End Sub

[gmayor]

The following adds the date prompts and I have added the missing function that caused the error and corrected a couple of issues with the code you added. You can't use Excel commands like ActiveWorkbook.Save in Outlook with late binding to Excel as here.

Option Explicit
Sub IsReplied()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim objItem As Outlook.MailItem
Dim iFolder As Folder
Dim xlApp As Object
Dim xlWB As Object
Dim xlInSheet As Object
Dim xlOutSheet As Object
Dim i As Long
Dim iNextInRow As Long, iNextOutRow As Long
Dim strWorkbookPath As String
Dim strWorkbook As String
Dim StartDate As String
Dim EndDate As String

    StartDate = InputBox("Enter Start Date", "Start Date", Format(Date, "dd/mm/yyyy"))
    If Not IsDate(StartDate) Then
        MsgBox "The date you entered is not valid"
        GoTo lbl_Exit
    End If
    EndDate = InputBox("Enter end Date", "end Date", Format(Date, "dd/mm/yyyy"))
    If Not IsDate(EndDate) Then
        MsgBox "The date you entered is not valid"
        GoTo lbl_Exit
    End If

    Const PropName As String = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
    strWorkbookPath = "C:\Testing\"        'path to save workbook must exist
    strWorkbook = strWorkbookPath & "UnrespondedEmails_Format(Now(), "DD-MM-YYYY hh mm ss AMPM") & "_MessageLog.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    'On Error GoTo 0
    xlApp.Visible = True
    'Open the workbook to input the data
    If Not FileExists(strWorkbook) Then
        Set xlWB = xlApp.Workbooks.Add
        With xlWB.Sheets(1)
            .Range("A1") = "SENDERNAME"
            .Range("B1") = "TO"
            .Range("C1") = "SUBJECT"
            .Range("D1") = "RECEIVEDTIME"
            .Range("E1") = "LASTMODIFICATIONTIME"
            .Range("F1") = "CATEGORIES"
            .Range("G1") = "UNREAD"
            .Range("H1") = "FLAGREQUEST"
        End With
        With xlWB.Sheets(2)
            .Range("A1") = "SENDERNAME"
            .Range("B1") = "TO"
            .Range("C1") = "SUBJECT"
            .Range("D1") = "RECEIVEDTIME"
            .Range("E1") = "LASTMODIFICATIONTIME"
            .Range("F1") = "CATEGORIES"
            .Range("G1") = "UNREAD"
            .Range("H1") = "FLAGREQUEST"
        End With
        xlWB.SaveAs Filename:=strWorkbook
    Else
        Set xlWB = xlApp.Workbooks.Open(strWorkbook)
    End If
    Set xlInSheet = xlWB.Sheets("Sheet1")
    Set xlOutSheet = xlWB.Sheets("Sheet2")

    'For i = Session.GetDefaultFolder(olFolderInbox).folders.Count To 1 Step -1 'Include sub folders
    Set iFolder = Session.GetDefaultFolder(olFolderInbox)        '.folders(') 'add to include sub folders

    For Each olItem In iFolder.Items
        If CDate(Format(olItem.ReceivedTime, "dd/mm/yyyy")) >= CDate(StartDate) And _
           CDate(Format(olItem.ReceivedTime, "dd/mm/yyyy")) <= CDate(EndDate) Then
            If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
                With xlInSheet
                    iNextInRow = xlInSheet.Range("A" & xlInSheet.Rows.Count).End(-4162).Row + 1
                    .Range("A" & iNextInRow) = olItem.Sender
                    .Range("B" & iNextInRow) = olItem.To
                    .Range("C" & iNextInRow) = olItem.Subject
                    .Range("D" & iNextInRow) = olItem.ReceivedTime
                    .Range("E" & iNextInRow) = olItem.LastModificationTime
                    .Range("F" & iNextInRow) = olItem.Categories
                    .Range("G" & iNextInRow) = olItem.UnRead
                    .Range("H" & iNextInRow) = olItem.FlagRequest
                End With
            Else
                iNextOutRow = xlOutSheet.Range("A" & xlOutSheet.Rows.Count).End(-4162).Row + 1
                With xlOutSheet
                    .Range("A" & iNextOutRow) = olItem.Sender
                    .Range("B" & iNextOutRow) = olItem.To
                    .Range("C" & iNextOutRow) = olItem.Subject
                    .Range("D" & iNextOutRow) = olItem.ReceivedTime
                    .Range("E" & iNextOutRow) = olItem.LastModificationTime
                    .Range("F" & iNextOutRow) = olItem.Categories
                    .Range("G" & iNextOutRow) = olItem.UnRead
                    .Range("H" & iNextOutRow) = olItem.FlagRequest
                End With
            End If
        End If
    Next olItem
    'Next i 'include subfolders
    xlWB.Save        '
    xlWB.Close
CleanUp:
    Set olItem = Nothing
    Set olItems = Nothing
    Set objItem = Nothing
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlInSheet = Nothing
    Set xlOutSheet = Nothing
lbl_Exit:
    Exit Sub
End Sub

Private Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

[parth007]

Perfectly worked in my case.. Thanks Graham
Appreciate your help