2

背景：

我有一个任务跟踪电子表格，并且想在每次向表中添加新行时创建一个日历“约会”。有许多不同版本的代码漂浮在那里，所以我把这些拼凑在一起，几乎没有真正的 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

问题：

  1. 如何调整代码以创建所有 600 多个约会？
  2. 如何将我的 .Subject 字符串合并到 Private Function 的 subjectFilter 中？

当前代码：

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
4

1 回答 1

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
于 2017-12-06T17:21:38.623 回答