Excel 代码问题的 Outlook 提醒

Question

我运行以下代码在 Outlook 中创建提醒。

' requires a reference to the Microsoft Outlook          x.0 Object Library
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in          Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
DeleteTestAppointments ' deletes previous test appointments
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp =   CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    MsgBox "Outlook is not available!"
    Exit Sub
End If
End If
r = 5 ' first row with appointment data in the active worksheet
While Len(Cells(r, 5).Formula) > 0
Set olAppItem =     olApp.CreateItem(olAppointmentItem) ' creates a    new appointment
With olAppItem
    ' set default appointment values
    On Error Resume Next
    .Start = Cells(r, 9).Value
    .End = Cells(r, 9)
    .Subject = Cells(r, 2).Value + Cells(r,        3).Value
    .Location = Cells(r, 5).Value
    .Body = Cells(r, 9).Value
    .ReminderSet = True
    .ReminderMinutesBeforeStart = 20160
    .Categories = "TestAppointment" ' add    this to be able to delete the testappointments
    On Error GoTo 0
    .Save ' saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
End Sub

Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
Dim olApp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim r As Long, dCount As Long
On Error Resume Next
Set olApp = GetObject("",     "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = GetObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    MsgBox "Outlook is not available!"
    Exit Sub
End If
End If
Set OLF =    olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
dCount = 0
For r = OLF.Items.Count To 1 Step -1
If TypeName(OLF.Items(r)) = "AppointmentItem" Then
    If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
        OLF.Items(r).Delete
        dCount = dCount + 1
    End If
End If
Next r
Set olApp = Nothing
Set OLF = Nothing
End Sub

但是我有一些异常情况；

1. 它并不总是将“主题”设置为相关行的第 2 列和第 3 列中写入的内容。它只是在提醒上返回一个空白。
2. 如果 L 列显示“隔离”或“检查”，我希望它不创建提醒。 任何帮助将不胜感激。

这里是excel工作簿http://db.tt/Goqni3uf的链接

Answer 1

很高兴你成功了 :)

对于下一个请求，在此条件之间嵌入您的代码

While Len(Cells(r, 5).Formula) > 0
    Select Case LCase(Cells(r, 12).Value)
        Case "quarantined", "inspected"
        Case Else
            '
            '~~> Your code to create an appointment
            '
    End Select
Wend