Создайте встречу Outlook, если ячейка содержит определенный текст

Question

Я пытаюсь создать новую встречу Outlook с данными Excel, если ячейка содержит слово «Да».

Sub AddAppointments()

' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")

' Start at row 4    
r = 4

Do Until Trim(Cells(r, 1).Value) = ""

    ' Create the AppointmentItem
    Set myApt = myOutlook.CreateItem(1)

    ' Set the appointment properties
    myApt.Subject = Cells(r, 3).Value
    myApt.Start = Cells(r, 7) + Cells(r, 8).Value

    If Trim(Cells(r, 5).Value) = "" Then
        myApt.BusyStatus = 2
    Else
        myApt.BusyStatus = Cells(r, 5).Value
    End If

    If Cells(r, 10).Value = "Yes" Then
        myApt.ReminderSet = True
    Else
        myApt.ReminderSet = False
    End If

    myApt.Body = "£" & Cells(r, 6).Value
        myApt.Save
        r = r + 1
    Loop
End Sub

Если ячейка содержит «Нет» или «Н / Д», она останавливается. Я хотел бы, чтобы это игнорировалось.

Answer 1

Как насчет этого?

Sub AppointmentAutomation()

    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")

    Dim oAppt As AppointmentItem
    Dim oPattern As RecurrencePattern
    Set oAppt = OutApp.CreateItem(olAppointmentItem)
    Set oPattern = oAppt.GetRecurrencePattern
    With oPattern
        .RecurrenceType = olRecursWeekly
        .DayOfWeekMask = olMonday
        .PatternStartDate = Worksheets("Sheet1").Range("A2")
        .PatternEndDate = Worksheets("Sheet1").Range("B2")
        .Duration = 60
        .StartTime = Worksheets("Sheet1").Range("C2")
        .EndTime = Worksheets("Sheet1").Range("D2")
    End With
    oAppt.Subject = Worksheets("Sheet1").Range("E2")
    oAppt.Save
    oAppt.Display

Set OutApp = Nothing

End Sub

Answer 2

Пример примера снимка рабочего листа прилагается ниже.

Следующий пример кода работает для меня.

Option Explicit    
Sub test2()

        Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
        r As Long, i As Long, WB As ThisWorkbook

        Set WB = ThisWorkbook
        Set ES = WB.Sheets("Sheet1")
        r = ES.Cells(Rows.Count, 1).End(xlUp).Row
        Set OL = New Outlook.Application
    For i = 2 To r
        Set Appoint = OL.CreateItem(olAppointmentItem)
        With Appoint
            .Subject = ES.Cells(i, 1).Value
            .Start = ES.Cells(i, 2).Value
            .End = ES.Cells(i, 3).Value
            .Location = ES.Cells(i, 4).Value
            .AllDayEvent = ES.Cells(i, 5).Value
            .Categories = ES.Cells(i, 6).Value & " Category"
            .BusyStatus = ES.Cells(i, 7).Value
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 60
            .Body = ES.Cells(i, 8).Value
            .Save
        End With
    Next i
     Set OL = Nothing

    End Sub

Редактировать

На основании комментариев ОП, размещение«Нуждается в погоне» в Column10.Пересмотренный код работает следующим образом.

Sub test3()

    Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
    r As Long, i As Long, WB As ThisWorkbook

    Set WB = ThisWorkbook
    Set ES = WB.Sheets("Sheet1")
    r = ES.Cells(Rows.Count, 1).End(xlUp).Row
    Set OL = New Outlook.Application
For i = 2 To r
    If ES.Cells(i, 10) = "Yes" Then
    Set Appoint = OL.CreateItem(olAppointmentItem)
    With Appoint
        .Subject = ES.Cells(i, 1).Value
        .Start = ES.Cells(i, 2).Value
        .End = ES.Cells(i, 3).Value
        .Location = ES.Cells(i, 4).Value
        .AllDayEvent = ES.Cells(i, 5).Value
        .Categories = ES.Cells(i, 6).Value & " Category"
        .BusyStatus = ES.Cells(i, 7).Value
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 60
        .Body = ES.Cells(i, 8).Value
        .Save
    End With
    End If
Next i
 Set OL = Nothing

End Sub