Outlook встречи из Excel VBA

Question

Я очень новичок в VBA и пытаюсь назначать встречи с определенной даты.Чтобы избежать дубликатов, я попытался раскрасить ячейки, но это не представляется жизнеспособным, и теперь я надеюсь сделать код проверяющим, существует ли встреча с тем же «субъектом», что и ячейка, и если это так, перейти к следующей строке, еслине создавать назначение.Я получаю сообщение об ошибке «Требуется объект» и не могу найти жизнеспособный подход для этого или это вообще возможно?Огромное спасибо всем, кто отвечает!

Private Sub Workbook_Open()
    Set myOutlook = CreateObject("Outlook.Application")
    r = 2

    Do Until Trim(Cells(r, 8).Value) = ""   
        If Cells(r, 9).Value = myapt.Subject = Cells(r, 9).Value Then
            r = r + 1      
        Else
            Set myapt = myOutlook.createitem(1)

            myapt.Subject = Cells(r, 9).Value
            myapt.Start = Cells(r, 8).Value
            myapt.AllDayEvent = True
            myapt.BusyStatus = 5
            myapt.ReminderSet = True
            'myapt.Body = ""
            myapt.Save

            Cells(r, 8).Interior.ColorIndex = 4
            r = r + 1
        End If    
    Loop
End Sub

Answer 1

Чтобы проверить, существует ли элемент, вам нужно отфильтровать существующие элементы:

Option Explicit

Public Sub CreateItemsIfNotExist()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your sheet!

    Dim olApp As Object  'create outlook application
    Set olApp = CreateObject("Outlook.Application")

    Dim olNS As Object 'get namespace
    Set olNS = olApp.GetNamespace("MAPI")

    'define constants if using late binding 
    Const olFolderCalendar As Long = 9
    Const olAppointmentItem As Long = 1

    Dim olRecItems As Object 'get all appointments
    Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)

    Dim strFilter As String  'filter for appointments
    Dim olFilterRecItems As Object 'filtered appointments

    Dim iRow As Long
    iRow = 2

    Do Until Trim$(ws.Cells(iRow, 8).Value) = vbNullString
        'filter appointments for subject
        strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 9).Value) & "'"
        Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)

        If olFilterRecItems.Count = 0 Then 'if subject does not exist
            With olApp.CreateItem(olAppointmentItem)
                .Subject = ws.Cells(iRow, 9).Value
                .Start = ws.Cells(iRow, 8).Value
                .AllDayEvent = True
                .BusyStatus = 5
                .ReminderSet = True
                .Save
            End With
            ws.Cells(iRow, 8).Interior.ColorIndex = 4
        End If

        iRow = iRow + 1
    Loop
End Sub

Обратите внимание, что, возможно, вы захотите выйти из прогноза в конце olApp.Quit.