Question

背景：

我有一个任务跟踪电子表格，并且每次在表格中添加新行时都希望创建日历“约会”。这个代码的不同版本有很多实例在那里浮动，所以我把它拼凑在一起，几乎没有真正的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字符串合并到私有函数中 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

Answer 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

用于创建Outlook约会的600多行Excel数据...但只创建一个约会

背景：

数据：

问题：

问题：

当前代码：

1 个答案: