Option Explicit

Sub CreateTasks()

    Dim olApp As Object
    Dim olTask As Object
    Dim LastRow As Long
    Dim i As Long
    Dim ctr As Long
    
    Set olApp = CreateObject("Outlook.Application")
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To LastRow
        If Cells(i, "A").Value <> "" Then
            Set olTask = olApp.createitem(3) 'olTaskItem
            With olTask
                [color=#FFFF00][i][b].Start = DateValue(Range("D" & ctr)) + TimeValue(Range("D" & ctr))[/b][/i][/color]
                .Subject = "Reminder - " & Cells(i, "A").Value
                .Body = Cells(i, "A").Value
                .Status = 1 'olTaskInProgress
                .Importance = 2 'olImportanceHigh
                .Duration = CLng(Range("G" & ctr)) ' 30
                .DueDate = Cells(i, "D").Value
                .ReminderSet = True
                .ReminderTime = Cells(i, "E").Value + TimeValue(Format(Cells(i, "F"), "HH:MM:SS"))
                .Save
            End With
        End If
    Next i
End Sub

Sub Outloook_Reminders()
Sheets("ReminderBook").Select
     Dim startRow As Long, endRow As Long, ctr As Long
   
     startRow = 2
     endRow = Cells(Rows.Count, 1).End(xlUp).Row
     
     For ctr = startRow To endRow
        With CreateObject("Outlook.application").createitem(1)
        On Error Resume Next
            .Start = DateValue(Range("C" & ctr)) + TimeValue(Range("C" & ctr))
            .Duration = CLng(Range("D" & ctr)) ' 60
            .Subject = CStr(Range("A" & ctr)) ' subject text
            .ReminderSet = True
            .Save
        End With
     Next
End Sub

Option Explicit
Option Base 0

Sub OutTask_Manager()

Dim OutApp As Object  'Для обращений к приложению Outlook
Dim OutTsk As Object  'Для создания задачи в Outlook
Dim OutMan As Object  'Для работы с получателем задачи
Dim shtX As Worksheet 'Для обращения к конкретному листу
Dim RecR() As String  'Для хранения имён получателей
Dim i As Long         'Для перебора получателей
Dim X As Long         'Для перебора создаваемых задач

Set shtX = ThisWorkbook.Worksheets("TaskBook")
Set OutApp = CreateObject("Outlook.Application")
X = 2

Do While shtX.Cells(X, 1).Value <> 0
    Set OutTsk = OutApp.CreateItem(3)
    ReDim RecR(0)
    RecR = Split(shtX.Cells(X, 3).Value, "; ")
    'Если в столбце "Получатель" кто-то указан, то добавляем его.
    If UBound(RecR) >= 0 Then
        For i = 0 To UBound(RecR)
            If RecR(i) <> "" Then
                OutTsk.assign
                Set OutMan = OutTsk.Recipients.Add(RecR(i))
                OutMan.Resolve
                If Not OutMan.Resolved Then
                    MsgBox ("Не удаётся назначить задачу пользователю: " & RecR(i) & vbNewLine & "По закрытию этого окна программа продолжит перебор получателей и строк.")
                    GoTo NextRow
                End If
            End If
        Next i
    End If
    'Заполняем задачу содержанием.
    With OutTsk
        .Subject = shtX.Cells(X, 1).Value 'Заголовок задачи
        .Body = shtX.Cells(X, 2).Value 'Текст задачи
        .ReminderSet = True 'Включить напоминание
        Select Case shtX.Cells(X, 4).Value 'Выбираем важность
            Case "Низкая": .Importance = 0
            Case "Обычная": .Importance = 1
            Case "Высокая": .Importance = 2
        End Select
        .StartDate = DateAdd("h", 10, shtX.Cells(X, 5).Value) 'Когда начать задачу
        .DueDate = DateAdd("h", 10, shtX.Cells(X, 6).Value) 'Дата завершения
        .ReminderTime = DateAdd("n", shtX.Cells(X, 8).Value * 60 + shtX.Cells(X, 9).Value, shtX.Cells(X, 7).Value) 'Дата напоминания
        'В зависимости от содержания в столбце "Получатель" отправляем или сохраняем задачу.
        Select Case UBound(RecR)
            Case -1: .Save
            Case Else: .SEND
        End Select
    End With
NextRow:
    X = X + 1
    Set OutTsk = Nothing
    Set OutMan = Nothing
Loop
Set OutApp = Nothing
End Sub