Блог

Главная - Вопросы по программированию - Удалить встречу Outlook, если ячейка содержит определенный текст

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

#excel #vba #outlook

#excel #vba #outlook

Вопрос:

В настоящее время у меня настроен код для добавления назначения в Outlook, если ячейка в Excel содержит слово «Нет». Что я хотел бы иметь возможность сделать, так это удалить существующую встречу, если та же ячейка изменена на «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 amp; 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

Ответ №1:

Оператор A With , If and 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 amp; 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

Комментарии:

1. Спасибо, сейчас я пытаюсь настроить его так, чтобы при удалении в ячейку вводилось «Да» (код изменен выше), но я получаю «ошибка метода или данных не найдена»?

2. Вы ссылаетесь на ES то, что не определено. Вы также устанавливаете объекты wb , ws но никогда не используете их в коде. Если вы хотите сослаться на wb.Worksheets("Section 74") , вам придется заменить ES на ws

3. Я уже установил ES в измененном коде, как указано выше, при отладке он выделяется .AppointmentItem в Set objAppointment = Outlook.AppointmentItem

4. Попробуйте Set objAppointment = objOutlook.AppointmentItem . Кроме того, все ваши заключительные инструкции перетасованы в вашем измененном коде. Я настоятельно рекомендую вам использовать правильные отступы.

5. Теперь я получаю «Ожидаемую функцию или переменную» со .Delete стороны With objAppointment.Delete ?

Ответ №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