Question

我希望根据Excel单元格中的日期在Outlook日历中自动设置提醒。

当您保存工作簿时，我当前正在运行它-然后它会自动在Outlook中填充提醒。

我的代码几乎可以正常工作，但是在进行一些更精细的调整时绊了脚步。

我希望代码忽略具有日期的列中的空白，而仅在该列的单元格中存在日期值的地方创建提醒。

我已经尝试了很多方法，但是无法使其正常运行。我目前使用下面在网上找到的其他代码，将代码放到下面。

请帮助！

Option Explicit
Public Sub CreateOutlookApptz()
   Sheets("Invoicing Schedule").Select
    On Error GoTo Err_Execute

    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim arrCal As String

    Dim i As Long

    On Error Resume Next
    Set olApp = Outlook.Application

    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If

    On Error GoTo 0

    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)

    i = 1
    Do Until Trim(Cells(i, 1).Value) = ""
    arrCal = Cells(i, 1).Value
     If Trim(Cells(i, 13).Value) = "" Then
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)

    'MsgBox subFolder, vbOKCancel, "Folder Name"

    With olAppt

    'Define calendar item properties
        .Start = Cells(i, 12) + TimeValue("9:00:00")
        .End = Cells(i, 12) + TimeValue("10:00:00")


        .Subject = "Invoice Reminder"
        .Location = "Office"
        .Body = Cells(i, 4)
        .BusyStatus = olFree
        .ReminderMinutesBeforeStart = 7200
        .ReminderSet = True
        .Categories = "Finance"
        .Save

    End With
    Cells(i, 13) = "Added"

    End If

        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing

    Exit Sub

Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."

End Sub

我只是想让它在列中查找，如果该列包含日期，那么它将基于另一个单元格值设置提醒。

Answer 1

建议像Siddharth一样，如果在正确的位置出现愚蠢应该可以解决问题...

尝试一下...

Option Explicit
Public Sub CreateOutlookApptz()

   Sheets("Invoicing Schedule").Select
    On Error GoTo Err_Execute

    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    Dim arrCal As String

    Dim i As Long

    On Error Resume Next
    Set olApp = Outlook.Application

    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If

    On Error GoTo 0

    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)

    i = 1
Do Until Trim(Cells(i, 1).Value) = ""

'IF Validation for Col 12 and 13    
If IsDate(Cells(i, 12)) And Ucase(Trim(Cells(i, 13))) <> "ADDED" Then

    arrCal = Cells(i, 1)

    Set olAppt = CalFolder.Items.Add(olAppointmentItem)

    'MsgBox subFolder, vbOKCancel, "Folder Name"

    With olAppt

    'Define calendar item properties
        .Start = Cells(i, 12) + TimeValue("9:00:00")
        .End = Cells(i, 12) + TimeValue("10:00:00")


        .Subject = "Invoice Reminder"
        .Location = "Office"
        .Body = Cells(i, 4)
        .BusyStatus = olFree
        .ReminderMinutesBeforeStart = 7200
        .ReminderSet = True
        .Categories = "Finance"
        .Save

    End With
    Cells(i, 13) = "Added"


End If

        i = i + 1
Loop
    Set olAppt = Nothing
    Set olApp = Nothing

    Exit Sub

Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."

End Sub

编辑：根据您的评论，您可以确定第12列中使用的单元格总数，例如LastRow = Cells(Rows.Count, 12).End(xlUp).Row，然后使用For Next循环遍历它。 / p>

以此替换您的Do Until块。

Dim LastRow As Long
LastRow = Cells(Rows.Count, 12).End(xlUp).Row

For i = 2 To LastRow

If IsDate(Cells(i, 12)) And UCase(Trim(Cells(i, 13))) <> "ADDED" Then

    arrCal = Cells(i, 1)

    Set olAppt = CalFolder.Items.Add(olAppointmentItem)

    'MsgBox subFolder, vbOKCancel, "Folder Name"

    With olAppt

    'Define calendar item properties
        .Start = Cells(i, 12) + TimeValue("9:00:00")
        .End = Cells(i, 12) + TimeValue("10:00:00")


        .Subject = "Invoice Reminder"
        .Location = "Office"
        .Body = Cells(i, 4)
        .BusyStatus = olFree
        .ReminderMinutesBeforeStart = 7200
        .ReminderSet = True
        .Categories = "Finance"
        .Save

    End With
    Cells(i, 13) = "Added"


End If

Next

从Excel工作表在Outlook中创建提醒

1 个答案: