600 + 行 Excel 数据创建 Outlook 约会...但只创建一个约会

Posted 2023-02-15

【中文标题】600 + 行 Excel 数据创建 Outlook 约会...但只创建一个约会

【英文标题】：600 + rows of Excel data to create Outlook Appointment...but only creates a single appointment

【发布时间】：2018-05-20 15:52:06

【问题描述】：

背景：

我有一个任务跟踪电子表格，并且想在每次向表中添加新行时创建一个日历“约会”。这段代码有很多不同版本的实例，所以我在几乎没有真正了解 VBA 的情况下将这些代码拼凑在一起。

数据：

数据存储在 Sheet1 中的表 (Table1) 中，我已将其重命名为“Tracker”。目前大约有 600 行和 16 列。该表会不断更新新的数据行。

问题：

宏运行，并遍历 600 多行数据，为一行创建约会，然后用下一行的数据覆盖该约会。我知道它正在创建 + 覆盖 b/c 我将日历视图设置为“列表视图”，然后运行宏……我可以看到它在所有不同的行中循环，所以我知道它在循环。所以我认为我需要帮助来修改私有函数的 subjectFilter。也就是说，如果我删除私​​有函数，它会做同样的事情。

现在，.Subject 代码是这样的：

.Subject = Cells(r, 9).Value & " (" & Cells(r, 13).Value & " " & Cells(r, 14).Value & ")"

虽然我可以将其简化为这样，如果它更容易合并到 subjectFilter 中：

.Subject = Cells(r, 9).Value

问题：

如何调整代码以创建所有 600 多个约会？ 如何将我的 .Subject 字符串合并到私有函数的 主题过滤器？

当前代码：

Sub SetAppt()

Dim olApp As Outlook.Application 
Dim olApt As AppointmentItem
Dim MySheet As Worksheet

Set MySheet = Worksheets("Tracker")
Set olApp = New Outlook.Application
Set olApt = olApp.CreateItem(olAppointmentItem)

For r = 2 To Cells(Rows.Count,1).End(xlUp).Row

With olApt
       .Start = Cells(r, 2).Value + TimeValue("10:30")
       .Duration = "1"
       .Subject = Cells(r, 9).Value & " (" & Cells(r, 13).Value & " " & Cells(r, 14).Value & ")"
       .Location = Cells(r, 5).Value
       .Body = "Follow up with task lead"
       .BusyStatus = olBusy
       .ReminderMinutesBeforeStart = 60
       .Categories = "Task Reminder"
       .ReminderSet = True
       .Save 

End With
Next

Set olApt = Nothing 
Set olApp = Nothing

End Sub


Private Function Get_Appointment(subject As String) As Outlook.AppointmentItem
'Private Function grabbed from here https://www.google.com/url?sa=t&rct=j&q=&esrc=s&source=web&cd=1&cad=rja&uact=8&ved=0ahUKEwis6IGw7vXXAhXBneAKHWJ9A7kQFggpMAA&url=https%3A%2F%2Fwww.mrexcel.com%2Fforum%2Fexcel-questions%2F686519-using-vba-macro-post-new-appointments-outlook-but-dont-want-duplicates.html&usg=AOvVaw0vUdR7HN9USe52hrOU2M1V

Dim olCalendarItems As Outlook.Items
Dim subjectFilter As String

'Get calendar items with the specified subject
    
subjectFilter = "[Subject] = '" & subject & "'"
Set olCalendarItems = olCalendarFolder.Items.Restrict(subjectFilter)

If olCalendarItems.Count > 0 Then
    Set Get_Appointment = olCalendarItems.Item(1)
Else
    Set Get_Appointment = Nothing
End If
End Function

【问题讨论】：

它是 same - 您只需在循环中多次修改它即可。您每次都需要创建一个新约会。

【参考方案1】：

为每一行使用一个新的约会对象 - 否则你只是创建一个约会然后重复更新它

Const COL_FLAG As Long = 20 '<< "flag" column
'...
'...
For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    'Only create an appointment if not already created....
    If Len(Cells(r, COL_FLAG ).Value)= 0 Then 
    With olApp.CreateItem(olAppointmentItem) '<<< use a new object for each iteration
           .Start = Cells(r, 2).Value + TimeValue("10:30")
           .Duration = "1"
           .Subject = Cells(r, 9).Value & " (" & Cells(r, 13).Value & _
                      " " & Cells(r, 14).Value & ")"
           .Location = Cells(r, 5).Value
           .Body = "Follow up with task lead"
           .BusyStatus = olBusy
           .ReminderMinutesBeforeStart = 60
           .Categories = "Task Reminder"
           .ReminderSet = True
           .Save 
           Cells(r, COL_FLAG ).Value = "Created"
    End With
    End If '<< appt not already created
Next

【讨论】：

Tim - 非常感谢 - 现在所有 600 多个项目都已创建，感谢您的帮助！我仍然无法创建重复项。有人提供了 Private Function - 但我不明白如何设置 PF 的 subjectFilter 所以下次我运行 SetAppt 宏时，只有新的数据行会创建约会。有什么想法吗？

每个appt的主题是唯一的吗？您需要某种方法将数据的每一行与现有日历项进行匹配，以查看它们是否匹配。另一种方法可能是在数据表中添加一个标志列，在创建 Outlook 项目后填充一个值：然后只处理该标志为空的行。

是的，主题都是独一无二的。主题是通过第 9、13 和 14 列中的单元格值生成的，产生一个名称 + ID 号 + 第二个 ID 号的字符串。不确定我是否遵循 flag 方法 - 你能详细说明我必须添加的 VBA 代码吗？

查看我的编辑以获取有关使用“标志”列的建议。

Tim - 谢谢你，我现在已经搞定了。我可能会修改它以创建会议邀请而不是约会项目，但我想我可以解决这个问题。感谢您的宝贵时间！