I was interested in a similar problem, so I wrote a code that solves the problem of finding a mutually accessible time interval for all recipients, taking into account your information about the meeting.
I was not sure exactly what you wanted as the output, so right now he just writes all the available times on the top line. The code is easily customizable to display all time intervals and free / busy status for individual recipients.
General code structure:
First, collect all the status of the free / busy recipient (like you). This is a gigantic string of numbers (0/1/2/3), which represent the availability for a given period of time (at given time intervals). Start at a specific date (today) and you can add minutes to get the correct DateTime for each time interval.
Store all accessibility information in an array collection. This is probably the best way to do this, but I wanted it to be simple.
Go through each time interval and find the time when all availability arrays add up to 0 (0 = free). In this case, print this specific time interval, and then go to the next.
Option Explicit Sub CheckAvail() Dim myOutlook As Object Dim myMeet As Object Dim i As Long 'Create the Outlook Session Set myOutlook = CreateObject("Outlook.Application") 'Create the AppointmentItem Set myMeet = myOutlook.CreateItem(1) myMeet.MeetingStatus = 1 i = 23 'Start at row 23 If Cells(i, 11) <> "" Then 'Add Recipients Do Until Trim(Cells(i, 10).Value) = "" 'Add all recipients myMeet.Recipients.Add Cells(i, 10) i = i + 1 Loop i = 23 myMeet.Start = Cells(i, 11).Value 'Set the appointment properties myMeet.Subject = Cells(i, 12).Value myMeet.Location = Cells(i, 13).Value myMeet.Duration = Cells(i, 14).Value myMeet.ReminderMinutesBeforeStart = 88 myMeet.BusyStatus = 2 myMeet.Body = Cells(i, 15).Value myMeet.Save myMeet.Display Else Call GetFreeBusyInfo End If End Sub Public Sub GetFreeBusyInfo() Dim myOutlook As Object Dim myMeet As Object Dim myNameSpace As Object Dim myRecipient As Object Dim i As Integer, totalMinutesElapsed As Long Dim myMeetingDuration As Integer, intFreeBusy As Integer, intTimeslot As Integer, intEarliestHour As Integer, intLatestHour As Integer Dim dtStartTime As Date, dtFinishTime As Date Dim myFBInfo As String Dim doHeaders As Boolean Dim intFreeBusyCode As Integer Dim recipStartRow As Integer recipStartRow = 23 ' defined by question/asker 'Create the Outlook Session Set myOutlook = CreateObject("Outlook.Application") Set myMeet = myOutlook.CreateItem(1) myMeet.MeetingStatus = 1 myMeetingDuration = CInt(Cells(recipStartRow, 14).Value) ' same as above - need duration 'Add all recipients i = 0 Do Until Trim(Cells(recipStartRow + i, 10).Value) = "" myMeet.Recipients.Add Cells(recipStartRow + i, 10) i = i + 1 Loop Set myNameSpace = myOutlook.GetNamespace("MAPI") ' uncomment to have all possible timeslots write out Dim debugRow As Integer, debugCol As Integer debugRow = 2 debugCol = 2 ' --> define the general 'working hours' here ' (anything timeslots that start before this period or end after this period will be ignored) intEarliestHour = 8 '8am intLatestHour = 17 '5pm ' set up structure to store free/busy info Dim colAvailability As Collection, colRecipients As Collection Dim strRecipientName As String Dim arrayAvailability(1 To 1000) As Integer Dim arrayStartDates(1 To 1000) As Date Set colAvailability = New Collection Set colRecipients = New Collection ' loop through each recipient (same as above) doHeaders = True i = 0 Do Until Trim(Cells(recipStartRow + i, 10).Value) = "" intTimeslot = 1 strRecipientName = Cells(recipStartRow + i, 10).Value Set myRecipient = myNameSpace.CreateRecipient(strRecipientName) 'Cells(debugRow + i, debugCol) = strRecipientName colRecipients.Add strRecipientName ' collections respect order of addition myFBInfo = myRecipient.FreeBusy(Date, myMeetingDuration, True) ' parse FB info string - stored as digits that represent Free/Busy constants, starting at midnight, in given time intervals For intFreeBusy = 1 To Len(myFBInfo) totalMinutesElapsed = CLng(intFreeBusy - 1) * myMeetingDuration dtStartTime = DateAdd("n", totalMinutesElapsed, Date) dtFinishTime = DateAdd("n", (totalMinutesElapsed + myMeetingDuration), Date) If Hour(dtStartTime) < intEarliestHour Or Hour(dtFinishTime) > intLatestHour Then ' skip this potential time slot Else intFreeBusyCode = CInt(Mid(myFBInfo, intFreeBusy, 1)) ' Cells(debugRow + i, debugCol + intTimeslot) = GetFreeBusyStatus(intFreeBusyCode) arrayAvailability(intTimeslot) = intFreeBusyCode If doHeaders = True Then ' Cells(debugRow - 1, debugCol + intTimeslot) = dtStartTime arrayStartDates(intTimeslot) = dtStartTime End If intTimeslot = intTimeslot + 1 End If Next intFreeBusy colAvailability.Add arrayAvailability ' save each recipients array of availability codes doHeaders = False i = i + 1 Loop ' search through each array to find times where everyone is available For intTimeslot = 1 To 1000 ' stop when we run out of time slots If arrayStartDates(intTimeslot) = #12:00:00 AM# Then Exit For End If dtStartTime = arrayStartDates(intTimeslot) ' loop through each meeting recipient at that time slot intFreeBusy = 0 For i = 1 To colRecipients.Count intFreeBusy = intFreeBusy + colAvailability.Item(i)(intTimeslot) Next i If intFreeBusy = 0 Then ' everyone is free! debugCol = debugCol + 1 Cells(debugRow - 1, debugCol).Value = dtStartTime End If Next intTimeslot 'myMeet.Close End Sub Function GetFreeBusyStatus(code As Integer) As String ' https://msdn.microsoft.com/en-us/library/office/ff864234.aspx ' 0 = free ' 1 = tentative ' 2 = busy ' 3 = out of office ' 4 = "working elsewhere" If code = 0 Then GetFreeBusyStatus = "Free" ElseIf code = 1 Then GetFreeBusyStatus = "Tentative" ElseIf code = 2 Then GetFreeBusyStatus = "Busy" ElseIf code = 3 Then GetFreeBusyStatus = "Out" ElseIf code = 4 Then GetFreeBusyStatus = "WFH" Else GetFreeBusyStatus = "??" End If End Function