Option Explicit

Public Sub ListAppointments()
On Error GoTo ErrHand:

    Application.ScreenUpdating = False

    Const olFolderCalendar As Byte = 9

    Dim olApp       As Object: Set olApp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = olApp.GetNamespace("MAPI")
    Dim olFolder    As Object
    Dim olApt       As Object
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("ivanov@mail.ru")
    Dim NextRow     As Long
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")

    objOwner.Resolve

    If objOwner.Resolved Then
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
    End If

    ws.Range("A1:E1").Value2 = Array("Subject", "Start", "End", "Location", "Body")

    If olFolder.Items.Count = 0 Then Exit Sub

    Dim myArr() As Variant: ReDim myArr(0 To 4, 0 To olFolder.Items.Count - 1)

    On Error Resume Next
    For Each olApt In olFolder.Items
        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        myArr(4, NextRow) = olApt.Body
        NextRow = NextRow + 1
    Next
    On Error GoTo 0

    ws.Range("A2:E" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)

    ws.Columns.AutoFit

cleanExit:
    Application.ScreenUpdating = True
    Exit Sub

ErrHand:
    Resume cleanExit
End Sub