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") 'Swap with your 5 room names
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change sheet name if you want it somewhere else
ws.Columns("A").ClearContents
row = 1
'Loop through each room
For i = LBound(Rooms) To UBound(Rooms)
RoomName = Rooms(i)
'Get the calendar folder for the room
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)
'Push information to Sheet1
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
