如果单元格包含特定文本，请删除 Outlook 约会

Question

>我目前设置了一个代码，如果Excel中的单元格包含单词"No"，则向Outlook添加约会。我希望能够做的是，如果相同的单元格更改为"N/A"，则删除现有约会。我试图为此改编我在其他地方找到的一些代码，但无法让它工作，目前它显示"编译错误：下一个没有 for">

Sub DeleteCalendarItems()
Dim r As Long, i As Long, wb              As Workbook
Dim ws              As Worksheet
Dim objOutlook      As Outlook.Application
Dim objNamespace    As Outlook.Namespace
Dim objFolder       As Outlook.MAPIFolder
Dim objAppointment  As Outlook.AppointmentItem
Dim strSubject      As String
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")

r = ws.Cells(Rows.Count, 1).End(xlUp).Row 'Rows.Count should also have a reference to a wb & ws
For i = 2 To r
    If ws.Cells(i, 9) = "N/A" Then
                ws.Cells(i, 13) = "Yes"
        Set objAppointment = oItems.Item(i)
        With objAppointment
            If .Subject = strSubject Then
                objAppointment.Delete
            End If
        End With
    End If
Next i
End Sub

Answer 1

With、

If 和 For 语句(以及更多(应始终关闭

Sub DeleteCalendarItems()
Dim wb              As Workbook
Dim ws              As Worksheet
Dim objOutlook      As Outlook.Application
Dim objNamespace    As Outlook.Namespace
Dim objFolder       As Outlook.MAPIFolder
Dim objAppointment  As Outlook.AppointmentItem
Dim strSubject      As String
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")

r = ES.Cells(Rows.Count, 1).End(xlUp).Row 'Rows.Count should also have a reference to a wb & ws
For i = 2 To r
    If ES.Cells(i, 9).Value = "N/A" Then
        Set objAppointment = oItems.Item(i)
        With objAppointment
            If .Subject = strSubject Then
                objAppointment.Delete
            End If
        End With
    End If
Next i
End Sub

Answer 2

我已经设法解决了(不知何故(-我需要添加一个嵌套的For循环

Sub DeleteNASec74()
Dim i As Long, j As Long
Dim wb              As Workbook
Dim ws              As Worksheet
Dim objOutlook      As Outlook.Application
Dim objNamespace    As Outlook.Namespace
Dim objFolder       As Outlook.MAPIFolder
Dim objAppointment  As Outlook.AppointmentItem
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.Items
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Section 74")

r = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To r
For j = oItems.Count To 1 Step -1
    If ws.Cells(i, 9).Value = "N/A" Then
    ws.Cells(i, 13) = "Yes"
        Set objAppointment = oItems.Item(j)
        With objAppointment
            If .Subject = "Send reminder email - " + ws.Cells(i, 2).Value Then
                objAppointment.Delete
            End If
        End With
    End If
Next j
Next i
End Sub