excel - 从工作表中的列表创建不重复的约会

Question

我正在尝试从给定日期进行约会。
为了避免重复，我尝试为单元格着色，但这似乎不可行。
现在我正在尝试检查是否存在与单元格具有相同“主题”的约会，如果存在则转到下一行。
我得到错误

Object required

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

请注意，也许您想最终退出 Outlook olApp.Quit .