Создание напоминаний в Outlook из листа Excel - PullRequest
Новая
       46

Создание напоминаний в Outlook из листа Excel

0 голосов
/ 03 апреля 2019

Я ищу автоматическую установку напоминаний в календаре Outlook на основе даты в ячейке в Excel.

У меня в данный момент это работает, когда вы сохраняете книгу - она ​​автоматически заполняет напоминания в 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

Я просто хочу, чтобы он заглянул встолбец, если этот столбец содержит дату, то он устанавливает напоминание на основе другого значения ячейки.

1 Ответ

0 голосов
/ 03 апреля 2019

Как предположил Сиддхарт, и если заговор в нужном месте должен помочь ...

Попробуй это ... 

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.

Замените ваш 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
...