我对一个类似的问题很感兴趣，所以我写了一些代码来解决为所有收件人找到一个相互可用的时间段的问题，给定您的会议信息。
我不确定你想要什么作为输出，所以现在它只是将所有可用的时间写到第一行。代码很容易调整以显示各个收件人的所有时间段和忙/闲状态。
代码的整体结构是：
首先，收集所有收件人的忙/闲状态（就像您所做的那样）。这是一个巨大的数字串（0/1/2/3），代表给定时间段（在给定持续时间间隔内）的可用性。从给定日期（今天）开始，您可以将分钟加起来以获得每个时间段的正确日期时间。
将所有可用性信息存储在数组集合中。可能是一种更好的方法，但我希望它简单明了。
遍历每个时间段并找到每个人的可用性数组加起来为 0（0 = 空闲）的时间。在这种情况下，打印出这个特定的时间段，然后继续下一个时间段。
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