View Single Post
 
Old 03-17-2015, 12:45 AM
gmayor's Avatar
gmayor gmayor is offline Windows 7 64bit Office 2010 32bit
Expert
 
Join Date: Aug 2014
Posts: 4,137
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

OK - The following should do that
Code:
Sub AddOutlookApptmnt()
Dim xlSheet As Worksheet
Dim olApp As Object
Dim objAppt As Object
Dim strDate As String
Dim strTime As String
Dim datOutlookDate As Date
Dim i As Long
Dim LastRow As Long
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

    Set xlSheet = ActiveWorkbook.Sheets(1)
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To LastRow        'Assumes a header row
            strDate = .Cells(i, "A")
            strTime = "07:00"
            datOutlookDate = CDate(strDate & " " & strTime)
            Set objAppt = olApp.CreateItem(1)
            With objAppt
                .Start = datOutlookDate
                .ReminderSet = True
                .AllDayEvent = True
                .Subject = "Payroll Info Due"
                .BusyStatus = 0
                .Save
            End With
        Next i
    End With
lbl_Exit:
    Set olApp = Nothing
    Set objAppt = Nothing
    Exit Sub
End Sub
The code for creating a task, which might be preferable, is similar:
Code:
Sub AddOutlookTask()
Dim xlSheet As Worksheet
Dim olApp As Object
Dim olTask As Object
Dim strDate As String
Dim i As Long
Dim LastRow As Long
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

    Set xlSheet = ActiveWorkbook.Sheets(1)
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To LastRow        'Assumes a header row
            strDate = .Cells(i, "A")
            Set olTask = olApp.CreateItem(3)
            With olTask
                .Subject = "Payroll Info Due"
                .StartDate = strDate
                .DueDate = strDate
                .Importance = 2
                '.Categories = "Payroll" 'add a category of your choice
                .Save
            End With
        Next i
    End With
lbl_Exit:
    Set olApp = Nothing
    Set olTask = Nothing
    Exit Sub
End Sub
Both codes run very quickly and nothing may appear to have happened, but check your Outlook
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote