其他答案略有改进

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

字符串

• 来自Tim评论的链接-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