Sub RoomAvailability()
Dim olApp As Object, olNamespace As Object, olFolder As Object
Dim olRecip As Object, olCalendar As Object, olItems As Object, olAppt As Object
Dim StartDate As Date, EndDate As Date, RoomName As String, Rooms As Variant
Dim i As Integer, ws As Worksheet, row As Integer, dateStrFilter As String
Set olApp = CreateObject("Outlook.Application")
Set olNamespace = olApp.GetNamespace("MAPI")
StartDate = Date
EndDate = Date + 1
Rooms = Array("MrExcel Room", "MrsExcel Room")
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Columns("A").ClearContents
row = 1
For i = LBound(Rooms) To UBound(Rooms)
RoomName = Rooms(i)
Set olRecip = olNamespace.CreateRecipient(RoomName)
olRecip.Resolve
If olRecip.Resolved Then
Set olFolder = olNamespace.GetSharedDefaultFolder(olRecip, 9)
Set olItems = olFolder.Items
olItems.Sort "[Start]"
olItems.IncludeRecurrences = True
dateStrFilter = "[Start] >= '" & Format(StartDate, "ddddd h:nn AMPM") & "' AND [End] <= '" & Format(EndDate, "ddddd h:nn AMPM") & "'"
Set olItems = olItems.Restrict(dateStrFilter)
ws.Cells(row, 1).Value = "Availability for " & RoomName & ":"
row = row + 1
If olItems.Count = 0 Then
ws.Cells(row, 1).Value = "No appointments found."
row = row + 1
Else
For Each olAppt In olItems
ws.Cells(row, 1).Value = olAppt.Subject & " from " & olAppt.Start & " to " & olAppt.End
row = row + 1
Next olAppt
End If
Else
ws.Cells(row, 1).Value = "Could not resolve recipient: " & RoomName
row = row + 1
End If
Next i
Set olAppt = Nothing
Set olItems = Nothing
Set olFolder = Nothing
Set olRecip = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
End Sub