从 Excel sheet 忽略空白单元格在 Outlook 中创建提醒

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 所建议的那样，如果 stament 在正确的位置应该可以解决问题...

试试这个...

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 然后使用 [=13 遍历它=]循环。

用这个替换你的 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 sheet 忽略空白单元格在 Outlook 中创建提醒

Creating reminders in Outlook from an Excel sheet ignoring blank cells

excel

vba

outlook

reminders