Sub OutTask_Manager()

'Author:    Roman "Rioran" Voronov
'Date:      the 2-nd of April, 2015
'Feedback:  voronov_rv@mail.ru

'Programm:  Allows user to create Outlook Tasks. If cell in column C is
'           empty, then task will be assigned to current user. In other
'           case recipient will be defined according to value.

'Програма:  Для создания задач в Outlook, версия 2. Позволяет не только
'           создавать задачи "для себя", но и отправлять запросы в виде
'           задач другим пользователям.

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

Set shtX = ThisWorkbook.Worksheets("Задачник")
Set OutApp = CreateObject("Outlook.Application")
X = 2

Do While shtX.Cells(X, 1).Value <> 0
     Set OutTsk = OutApp.CreateItem(3)
     RecR = shtX.Cells(X, 3).Value
     If RecR <> "" Then
         OutTsk.assign
         Set OutMan = OutTsk.Recipients.Add(RecR)
         OutMan.Resolve
         If Not OutMan.resolved Then
             MsgBox ("Не удаётся назначить задачу пользователю: " & RecR & vbNewLine & "По закрытию этого окна программа продолжит перебор строк.")
             GoTo NextRow
         End If
     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 RecR
             Case "": .Save
             Case Else: .Send
         End Select
     End With
NextRow:
     X = X + 1
     Set OutTsk = Nothing
     Set OutMan = Nothing
Loop
Set OutApp = Nothing
End Sub

Sub Rio_Cleaner()
     Dim X As Long
     With ThisWorkbook.Sheets("Задачник")
         X = .Cells(.Rows.Count, 1).End(xlUp).Row
         If X > 1 Then .Range("A2:I" & X).Value = "" Else MsgBox "Чистить нечего"
     End With
End Sub

'Пример заполнения ячейки для нескольких пользователей: someoneСОБАКАmail.ru; elseoneСОБАКАgmail.com; anywhoСОБАКАsample.uk

Option Explicit
Option Base 0

Sub OutTask_Manager()

'Author:    Roman "Rioran" Voronov
'Date:      Version 3, the 16-th of June, 2015
'Feedback:  voronov_rv@mail.ru

'Programm:  Allows user to create Outlook Tasks. If cell in column C is
'           empty, then task will be assigned to current user. In other
'           case recipient will be defined according to value. Several
'           recepients must be delimited with semicolon and one space.

'Програма:  Для создания задач в Outlook, версия 3. Позволяет не только
'           создавать задачи "для себя", но и отправлять запросы в виде
'           задач другим пользователям. Несколько пользователей должны
'           быть разделены точкой с запятой и пробелом.

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("Задачник")
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

Sub Rio_Cleaner()
         Dim X As Long
         With ThisWorkbook.Sheets("Задачник")
             X = .Cells(.Rows.Count, 1).End(xlUp).Row
             If X > 1 Then .Range("A2:I" & X).Value = "" Else MsgBox "Чистить нечего"
         End With
End Sub

Set myDelegate = OutTsk.Recipients.Add("name user")