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