Count of Email by Sender from Outlook folder

Question

Is am new to writing VBA code , I would really really appreciate if anyone can help me with a VBA macro that can do the job of counting all emails by the sender's email address , within a particular Outlook folder.
If the count of emails from a particular sender is more than 1 , it should populate an excel sheet with data of the email adddress and the time of receipt of the mail from that sender .

Answer 1

It is not clear whether you want to process all the messages in the folder, or just those from a particular sender. The following does the latter.
The former would be rather more complicated if you want to record messages from senders that have sent more than one message. Recording all messages in a folder is much simpler.
Change the folder to the location where you want to store the workbook and
allow the macro to create that workbook.
Option Explicit
Private olNS As Outlook.NameSpace
Private olFolder As Outlook.MAPIFolder
Private olItems As Outlook.Items
Private olMsg As Outlook.MailItem
Private Count As Long
Private strDate As String
Private strTime As String
Private strFrom As String
Private strEmail As String
Private strSubject As String
Private strValues As String
Private vValues As Variant
Private ConnectionString As String
Private strSQL As String
Private CN As Object
Private xlApp As Object
Private xlWB As Object
Private bXLStarted As Boolean
Private nAttr As Long
Private i As Long
Private Const strTitles As String = "Date|Time|From|E-Mail"
Private Const strWorkbook As String = "C:\Path\Message Log.xlsx"
Sub MessageLog()
    Count = 0
    strFrom = InputBox("Enter sender's name to record." & vbCr & _
                       "Exact spelling is essential.")
    If strFrom = "" Then Exit Sub
    Set olNS = Outlook.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    Set olItems = olFolder.Items
    For Each olMsg In olItems
        'MsgBox olMsg.Sender & vbCr & strFrom
        If olMsg.Sender = strFrom Then
            Count = Count + 1
            If Count = 2 Then Exit For
        End If
    Next olMsg
    'MsgBox Count & vbCr & strFrom
    If Count > 1 Then
        MsgBox "A completion message will indicate when the process has finished."
        For Each olMsg In olItems
            If olMsg.Sender = strFrom Then
                RecordMessage olMsg
                DoEvents
            End If
        Next olMsg
    End If
    MsgBox "Process Complete."
lbl_Exit:
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olItems = Nothing
    Set olMsg = Nothing
    Exit Sub
End Sub
Sub RecordMessage(Item As Outlook.MailItem)
    strFrom = Item.SenderName
    strEmail = Item.SenderEmailAddress
    strDate = Format(Item.ReceivedTime, "dd/MM/yyyy")
    strTime = Format(Item.ReceivedTime, "h:mm am/pm")
    strSubject = Item.Subject
    strValues = strDate & "', '" & _
                strTime & "', '" & _
                strFrom & "', '" & _
                strEmail
    If Not FileExists(strWorkbook) = True Then xlCreateBook strWorkbook:=strWorkbook, strTitles:=strTitles
    WriteToWorksheet strWorkbook:=strWorkbook, strRange:="Sheet1", strValues:=strValues
lbl_Exit:
    Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
                                  strRange As String, _
                                  strValues As String)
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                       "Data Source=" & strWorkbook & ";" & _
                       "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    Set CN = CreateObject("ADODB.Connection")
    Call CN.Open(ConnectionString)
    Call CN.Execute(strSQL, , 1 Or 128)
    CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function
Private Sub xlCreateBook(strWorkbook As String, strTitles As String)
    vValues = Split(strTitles, "|")
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXLStarted = True
    End If
    On Error GoTo 0
    Set xlWB = xlApp.Workbooks.Add
    With xlWB.Sheets(1)
        For i = 0 To UBound(vValues)
            .Cells(1, i + 1) = vValues(i)
        Next i
    End With
    xlWB.SaveAs strWorkbook
    xlWB.Close 1
    If bXLStarted Then
        xlApp.Quit
        Set xlApp = Nothing
        Set xlWB = Nothing
    End If
lbl_Exit:
    Exit Sub
End Sub
Private Function FileExists(ByVal Filename As String) As Boolean
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
    Exit Function
End Function
Graham Mayor - Word MVP
www.gmayor.com