Option Explicit
Option Base 0

Sub Rio_OutLook_Time_Manager()

'Author:    Roman "Rioran" Voronov
'Date:      the 24-th of November, 2014
'Feedback:  voronov_rv@mail.ru

'Программа для переноса из файла Excel в Outlook событий "Собрание" и "Встреча"

Dim olApp As Object  'Для обращений к приложению АутЛук
Dim NewX As Object   'Для создания объекта события
Dim Others As String 'Для работы со списком людей
Dim NewMan As Object 'Для добавления нового участника

Dim They             'Массив приглашенных
Dim R As Byte        'Обработка события
Dim X As Long        'Для перебора строк
Dim A As Long        'Для перебора участников
Dim H As Long        'Высота Таблицы

H = Cells(Rows.Count, 1).End(xlUp).Row
If H < 2 Then Exit Sub
Set olApp = CreateObject("Outlook.Application")

For X = 2 To H
        Select Case Cells(X, 1).Value
            Case "": R = 0
            Case "Собрание": R = 1
            Case "Встреча": R = 2
        End Select
        If R > 0 Then
            Set NewX = olApp.CreateItem(1)
            With NewX
                .MeetingStatus = R
                They = Split(Cells(X, 4).Value, ", ")
                Select Case R
                    Case 1
                        For A = 0 To UBound(They)
                            Others = "<" & They(A) & ">"
                            Set NewMan = NewX.Recipients.Add(Others)
                            NewMan.Type = 1
                        Next A
                        Others = ""
                    Case 2
                        Others = "Участники встречи:" & vbNewLine & vbNewLine
                        For A = 0 To UBound(They)
                            Others = Others & They(A) & vbNewLine
                        Next A
                End Select
                .Subject = Cells(X, 2).Value
                .Location = Cells(X, 3).Value
                .Body = Cells(X, 5).Value & vbNewLine & vbNewLine & Others 'Текст
                .Categories = Cells(X, 6).Value
                .Start = Cells(X, 7).Value + Cells(X, 8).Value
                .End = Cells(X, 9).Value + Cells(X, 10).Value
                If Cells(X, 11).Value = "Да" Then
                    .ReminderSet = True
                    .ReminderMinutesBeforeStart = Cells(X, 12).Value
                Else
                    .ReminderSet = False
                End If
                Select Case R
                    Case 1: .Send
                    Case 2: .Save
                End Select
            End With
        End If
Next X

Set They = Nothing
Set NewMan = Nothing
Set NewX = Nothing
Set olApp = Nothing

End Sub