Populate excel spreadsheet with email tracking results

[Bombaye]

I curently manage an after work football session but it's getting quite laborious. What I would like to know is whether you can populate an excel spreadsheet with results from an email with voting options automatically.

I've seen tips on the web that tell you how to copy tracking results to excel but I would like to automate it so that I can send the email with voting, people then vote, and I can then open the spreadsheet and have the list of those who voted yes to be able to play rather than keying it in manually.
I have used vba but not to any great extent as most of it is done for me.
Is this possible?

 

[tweedle]

It is possible.

This one actually runs from Outlook [modified version of a project collector I run]

Requires Outlook to have a reference to the Microsoft Excel Object Library
You need to update the path to the Excel file to use in logging. [See Red]
Will promt you for a begin date and end date to scan.
Then it will go through your Inbox and collect items within those dates that have Voting Responses.

Good Luck!

Sub AutoLogXLS_From_EMailVotingResponses()
'Outlook Module: Scans Inbox for E-Mails with Voting Responses
'Logs them to Excel file
'Requires Reference to Microsoft Excel xx.x Object Library [Outlook/Alt F11/Tools/References]
'Constants
    Const moduleName = "AutoLogXLS_From_EMailVotingResponses"
    Const AutoLogFile = "H:\Temp\AutoResponseLog.xls"    ' [COLOR=red]UPDATE THIS[/COLOR] to the file receiving the log info
    Const MESSAGE_CAPTION = "Collecting Inbox"
    Dim oOutlook As New Outlook.Application
    Dim MyMailItems As Outlook.Items
    Dim intCtr As Integer
    Dim dteUpdated As Date
    Dim strMessage As String
    Dim EndDateDefault As String
    Dim dtretval As Date
    Dim lastday As Integer
    'Determine last day of the month
    lastday = 32
    Do
        lastday = lastday - 1
        Err = 0
        On Error Resume Next
        dtretval = CDate(Month(Now()) & "/" & lastday & "/" & Year(Now()))
        DoEvents
    Loop Until Err.Number = 0
    EndDateDefault = Month(Now()) & "/" & lastday & "/" & Year(Now())
    'END Determine last day of the month
    
    'Prompt for scan dates
    Dim StartDate, EndDate As Date
    StartDate = CDate(InputBox("Start Date: ", "A Little help here....", Month(Now()) & "/01/" & Year(Now())))
    EndDate = CDate(InputBox("End Date: ", "A Little help here....", EndDateDefault))
    'END Prompt for scan dates
    On Error GoTo Err_Handler
    'Set up Outlook objects
    Dim myFolder As Folder
    Set myFolder = oOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set MyMailItems = oOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items
    'Set up Excel Objects
    'Requires Reference to Microsoft Excel xx.x Object Library
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = Workbooks.Open(AutoLogFile)
    Set ws = wb.Sheets(1): ws.Activate
    wb.Application.Visible = True
    Dim lastrow, colidx As Long
    
    'Set Labels
    colidx = 1
    Cells(1, colidx) = "Received": colidx = colidx + 1
    Cells(1, colidx) = "Vote/Subject": colidx = colidx + 1
    Cells(1, colidx) = "Sender Name": colidx = colidx + 1
    Cells(1, colidx) = "Date Recorded": colidx = colidx + 1
    Cells(1, colidx) = "Outlook Routine": colidx = colidx + 1
    Cells(1, colidx) = "Folder Scanned": colidx = colidx + 1
    dtLogDate = Now()
    
    lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
    colidx = 1
    'Cycle through Mail Items
    If MyMailItems.Count > 0 Then
        For intCtr = MyMailItems.Count To 1 Step -1
            If MyMailItems(intCtr).Class = 43 Then    'EMail//olMail
                If MyMailItems(intCtr).ReceivedTime >= StartDate And _
                MyMailItems(intCtr).ReceivedTime <= EndDate And _
                MyMailItems(intCtr).VotingResponse <> "" Then
                    'Found one, Add to Excel
                    colidx = 1
                    Cells(lastrow, colidx) = MyMailItems(intCtr).ReceivedTime: colidx = colidx + 1
                    Cells(lastrow, colidx) = MyMailItems(intCtr).Subject: colidx = colidx + 1
                    Cells(lastrow, colidx) = MyMailItems(intCtr).SenderName: colidx = colidx + 1
                    Cells(lastrow, colidx) = dtLogDate: colidx = colidx + 1
                    Cells(lastrow, colidx) = moduleName: colidx = colidx + 1
                    Cells(lastrow, colidx) = myFolder.Name: colidx = colidx + 1
                    lastrow = lastrow + 1
                End If
            End If    'class
            DoEvents
            'Optional update to Excel Status Bar
            wb.Application.StatusBar = intCtr & " of " & MyMailItems.Count
        Next intCtr
        wb.Application.StatusBar = ""
        wb.Activate
        
        ws.Columns("A:F").Select
        ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        wb.Close SaveChanges:=True
        strMessage = "Completed Scrolling of InBox"
        MsgBox strMessage, vbOKOnly, MESSAGE_CAPTION
    Else
        strMessage = "Something isn't right!"
        MsgBox strMessage, vbCritical, MESSAGE_CAPTION
    End If
Exit_EmailScan:
    On Error Resume Next
    Set oOutlook = Nothing
    Exit Sub
Err_Handler:
    strMessage = "An unexpected error, #" & Err & " : " & _
                 Error & " has occured."
    Resume Exit_EmailScan
End Sub