Hi,

I have a worksheet in which i extract email IDs from Outlook, of people
opting for a drop time.

I send out a voting response mail & the responses are collected into a
custom folder "DropTime" created below Inbox.

The code uses "Find" to search for Voting responses (in Subject)
formatted as text, like 0:30;1:00;1:30 etc...in the DropTime folder &
extracts the SenderName & puts them under the respective columns.


The Header columns in the Worksheet are the same text
0:00;0:30;1:00;1:30 etc....

A B C D E
F
0:00 0:30 1:00 1:30 2:00
2:30
-------------------------------------------------------------------------------

John Sam Masey Shirley
Fabian Dolly Manoj Raul
Gatsy
Hurley


etc,......

The only problem with the following code is that it only processes some
of the mails & not all (Dont know why). So i have to run the code again
& again to process them, which is tiresome as there are around 200-250
mails. I think i need to use FindNext to process the remaining mails,
but donot know how to get it in the loop.

========================
Function CreateInboxFolder(oInbox, Fldr) As Object

Dim oFold As Object

'Look for archive folder and create if doesn't exist, create it
On Error Resume Next 'ignore error
Set oFold = oInbox.Folders(Fldr)
If Err.Number 0 Then Err.Clear

If oFold Is Nothing Then
Set oFold = oInbox.Folders.Add(Fldr, olFolderInbox)
End If

Set CreateInboxFolder = oFold

End Function
Function GetOutlook() As Object

Dim olApp As Object

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not running: please open the application first"
End If

Set GetOutlook = olApp

End Function

Sub GetDropTimeVotes()

Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Dim objMail As Outlook.MailItem
Dim objItem As Object
Dim olApp As Outlook.Application

If olApp Is Nothing Then
Set olApp = GetOutlook()
End If


Dim objWks As Excel.Worksheet
Dim objTimeRange As Excel.Range, objRange As Excel.Range
Dim iRow
Dim FolderName As Object

On Error Resume Next
Set objNS = olApp.GetNamespace("MAPI")
Set objInbox =
objNS.GetDefaultFolder(olFolderInbox).Folders("Dro pTime")

Set objWks = ThisWorkbook.Worksheets("Drops") 'Use default Sheet1
With objWks
iRow = objWks.Cells(objWks.Rows.Count, 1).End(xlUp).Row + 1
End With

Set objTimeRange = objWks.UsedRange

For Each objItem In objInbox.Items
If objItem.Class = olMail Then
Set objMail = objItem

If objItem.VotingResponse "" Then
Set objRange =
objTimeRange.Find(objMail.VotingResponse, , , xlWhole)
If Not objRange Is Nothing Then
objWks.Cells(iRow, objRange.Column).Value =
objMail.SenderName
End If
Set FolderName = CreateInboxFolder(objInbox, "DropTime"
& "-" & Date)
objMail.Move FolderName
iRow = iRow + 1
End If
End If
Next

Set objItem = Nothing
Set objRange = Nothing
Set objTimeRange = Nothing
Set objMail = Nothing
Set objWks = Nothing
Set objExcel = Nothing
Set objNS = Nothing
Set objInbox = Nothing
Set olApp = Nothing
End Sub
========================================


Is there a way to process them in one go......???

Rgds,

Junoon