Создание неповторяющихся встреч из списка на листе
Я пытаюсь записаться на прием с определенной даты.
Чтобы избежать дубликатов, я попытался раскрасить ячейки, но это не кажется жизнеспособным.
Теперь я пытаюсь проверить, существует ли встреча с тем же «субъектом», что и ячейка, и если да, то перейти к следующей строке.
я получаю ошибку
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
Спасибо за разъяснение, однако, если я объявлю Set myapt = myOutlook.createitem(1), я больше не получаю ошибку, но строка Cells(r, 9).Value = myapt.Subject = Cells(r, 9).Value делает похоже, не работает должным образом... Я хочу проверить, существует ли встреча с текущим субъектом, и теперь код работает, но ЕСЛИ позволяют создавать дубликаты
Ну, в этой строке есть один = слишком много If Cells(r, 9).Value = myapt.Subject = Cells(r, 9).Value Then вы, вероятно, хотели использовать If Cells(r, 9).Value = myapt.Subject Then?
Мне стыдно за глупые ошибки здесь, однако он все еще делает дубликаты ... Может ли быть так, что он не может проверить, существует ли уже встреча с этим субъектом, или мне просто нужно продолжать копать, чтобы добраться туда?
Ответы 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.
Большое спасибо за усилия, однако это по-прежнему создает дубликаты, если я, например, запускаю код дважды, поэтому я думаю, что что-то не так. Идея состоит в том, чтобы он запускался при открытии и назначал встречи на даты, если они не существуют.
Извините, я сделал ошибку копирования/вставки, столбец в фильтре должен быть столбцом 9, а не 8. Измените его на strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 9).Value) & "'"
В этой строке
Cells(r, 9).Value = myapt.Subject = Cells(r, 9).Valueпеременная/объектmyaptеще не объявлена/не установлена, поэтому вы не можете использовать ее на данный момент. Правильно объявите все свои переменные иsetвсе объекты до, которые вы их используете. АктивируйтеOption Explicit: в редакторе VBA перейдите к Инструменты › Опции › Требовать объявление переменной, чтобы убедиться, что вы объявили все переменные.