Excel Создать мероприятие в календаре Outlook

Небольшое улучшение по другому ответу

Sub createappt()

Const olFolderCalendar = 9
Const olAppointmentItem = 1 '1 = Appointment

Set objOutlook = CreateObject("Outlook.Application")

'Set objOutlook = GetObject(, "Outlook.Application")  ' outlook already open
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set Items = objNamespace.GetDefaultFolder(olFolderCalendar).Items

Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar).Folders("subfolder")
Set objCalendar = objNamespace.GetDefaultFolder(olFolderCalendar) ' main calender
Set objapt = objCalendar.Items.Add(olAppointmentItem)
objapt.Subject = "Test" 'Owner
objapt.Start = Date + TimeValue("08:00:00")
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
objapt.End = Date + TimeValue("16:00:00")
objapt.Save
End Sub

Это позволит вам добавить встречу в общий Календарь в любой папке, если у вас есть права на запись в ней.

Рассматривать календарь как папку

Const olFolderInbox = 6
Const olAppointmentItem = 1 '1 = Appointment

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
'Finds your Inbox
Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)

'Gets the parent of your Inbox which gives the Users email
strFolderName = objInbox.Parent
Set objCalendar = objNamespace.Folders("Public folders - " & strFolderName).Folders("SubFolder1").Folders("subfolder of subfolder 1").Folders("Your Calendar")

Set objapt = objCalendar.Items.Add(olAppointmentItem)
objapt.Subject = "Test" 'Owner
objapt.Start = Date + TimeValue("08:00:00")
objapt.Duration = 60 * 8 'Duration(in minutes) OR End(I'm not sure so try both)
objapt.End= Date + TimeValue("16:00:00")
objapt.Save

Ссылка на комментарий Тима - http://excelexperts.com/Creating-appointments-for-outlook-in-VBA

Sub AddAppointments2()
    ' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")

    ' Start at row 2
    r = 2

    Do Until Trim(Cells(r, 1).Value) = ""
        For Each olapt In olFldr.Items
            If TypeName(myApt) = "AppointmentItem" Then
                If InStr(1, myApt.Subject, "Test and Tag", vbTextCompare) Then
                    myApt.Body = appt.Body & Cells(r, 2)
                    myApt.Save
                Else
                    ' Create the AppointmentItem
                    Set myApt = myOutlook.createitem(1)
                    ' Set the appointment properties
                    myApt.Subject = Cells(r, 1).Value
                    myApt.Location = Cells(r, 2).Value
                    myApt.Start = Cells(r, 4).Value + TimeValue("08:00:00")
                    myApt.Duration = Cells(r, 5).Value
                    ' If Busy Status is not specified, default to 2 (Busy)
                    If Trim(Cells(r, 6).Value) = "" Then
                        myApt.BusyStatus = 2
                    Else
                        myApt.BusyStatus = Cells(r, 6).Value
                    End If
                    If Cells(r, 7).Value > 0 Then
                        myApt.ReminderSet = True
                        myApt.ReminderMinutesBeforeStart = Cells(r, 7).Value
                    Else
                        myApt.ReminderSet = False
                    End If
                    myApt.Body = Cells(r, 12).Value
                    myApt.Save
                    r = r + 1
                End If
            End If
        Next olapt
    Loop
End Sub

Вот другая ссылка https://stackoverflow.com/a/49121400/4539709