Sub addAppointmentToAnyOutlookCalendarFromExcel()

    Dim objApp          As Object 'Outlook.Application
    Dim objCalendar     As Object 'Outlook.Folder
    Dim objExplorer     As Object 'Outlook.Explorer
    Dim objModule       As Object 'Outlook.CalendarModule
    Dim objGroup        As Object 'Outlook.NavigationGroup
    Dim objNavFolder    As Object 'Outlook.NavigationFolder
    Dim objAppoint      As Object 'Outlook.AppointmentItem
    
    Set objApp = CreateObject("Outlook.Application")
    Set objCalendar = objApp.Session.GetDefaultFolder(9) '9 = olFolderCalendar
    Set objExplorer = objCalendar.GetExplorer
    
    Set objModule = objExplorer.NavigationPane.Modules.Item("Календарь")
    Set objGroup = objModule.NavigationGroups.Item("Мои календари") '.Item("Общие календари")
    Set objNavFolder = objGroup.NavigationFolders.Item("Calendar") '.Item("отгулы, отпуска")
    
    Set objAppoint = objNavFolder.Folder.Items.Add(1) '1 = olAppointmentItem
                
    With objAppoint
        .Start = DateSerial(2014, 11, 25) + TimeValue("23:45:00")
        .Duration = 30
        .Subject = "subject of appointment"
        .Save
    End With
    
    Set objAppoint = Nothing
    Set objNavFolder = Nothing
    Set objGroup = Nothing
    Set objModule = Nothing
    Set objExplorer = Nothing
    Set objCalendar = Nothing
    
    objApp.Quit
    Set objApp = Nothing

End Sub

Set objAppoint = objNavFolder.Folder.Items.Add(1) '1 = olAppointmentItem

Attribute VB_Name = "Module2"
Sub AddToOutlook()

Dim olAppointment As Outlook.AppointmentItem
Dim olApp As Excel.Application
Dim lngRow As Long, shtSource
Dim outapp As Outlook.Application

Dim x As Date
On Error Resume Next
        Set olApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
        Set olApp = CreateObject("Excel.Application")
End If

On Error GoTo 0
        Set shtSource = ThisWorkbook.Sheets("Воронка")

For i = 2 To 404   'Число строк по которое работает цикл выгрузки в календарь

If shtSource.Cells(i, 10) = "" Then 'если не будет значения - выгрузка не происходит

End If

' проверка значения "Встреча"

If shtSource.Cells(i, 15) = "встреча" Then   ' Условие по которому работает выгрузка
If shtSource.Cells(i, 10) > 0 Then           ' Условие по которому работает выгрузка

x = Cells(i, 10) ' дата

        Set outapp = New Outlook.Application
        Set olAppointment = outapp.CreateItem(1) ' создание события в Outlook "встреча"

    With olAppointment
        .Subject = "СХ: " + shtSource.Cells(i, 2)                   'тема
        .Location = shtSource.Cells(i, 14)                          'место
        .Start = shtSource.Cells(i, 10) + shtSource.Cells(i, 11)    'начало события
        .Duration = 60                    'продолжительность события
        .Body = shtSource.Cells(i, 17)                    'Тело письма
        .Categories = "Встреча с клиентом"                          ' категория в Outllok'е для раскраски
        .Save                    'сохранить
'        .Display                    'показать
'        .Send                    'отправить

End With

End If
End If

' проверка значения "Звонок"

If shtSource.Cells(i, 15) = "звонок" Then ' Условие по которому работает выгрузка

x = Cells(i, 10) ' дата

        Set outapp = New Outlook.Application
        Set olAppointment = outapp.CreateItem(1)

    With olAppointment
        .Subject = "ОТ: " + shtSource.Cells(i, 2)                   'тема
        .Location = shtSource.Cells(i, 14)                          'место
        .Start = shtSource.Cells(i, 10) + shtSource.Cells(i, 11)    'начало события
        .Duration = 30                    'продолжительность события
        .Body = shtSource.Cells(i, 17)                    'Тело письма
'        .Categories = "Встреча с клиентом"                          ' категория в Outllok'е для раскраски
        .Save                    'сохранить
'        .Display                    'показать
'        .Send                    'отправить
End With
End If
Next i
End Sub