Excel Appointment Task Schedule Update Macro

Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

clarkj5

Thread Starter
Joined
Jan 12, 2011
Messages
6
Hi,

I have been putting a couple of macros together to export a series of jobs in an excel spreadsheet into either a task list or calendar in outlook.

I require that the entry is updated if already present. The task macro works but the calendar macro is not. It seems to stick on a count function. I was wondering whether this was due to the amount of entries I already have in my outlook calendar? The codes are listed below. If anyone can offer advice/help in how to overcome the issue I would be very greatful. If the code can be simplified, that would also be a bonus.

When checking to update, the macro looks at subject field

TASK CREATE/UPDATE/DELETE MACRO :-

Private Sub cmdTasks_Click()
Dim OL As Outlook.Application
Dim OL_TK As Outlook.TaskItem
Dim OL_NS As Outlook.Namespace
Dim OL_FL As Outlook.MAPIFolder
Dim OL_TK_Crit As String
Dim OL_TK_i, UP_i, NE_i, DE_i As Integer
Dim w As Workbook
Dim s As Worksheet
Set s = Worksheets("Task Assigner")
Dim c As Range
UP_i = 0
NE_i = 0
DE_i = 0
For i = 3 To s.Range("A2").CurrentRegion.Rows.Count
Set c = s.Cells(i, 1)
OL_TK_Crit = c.Offset(0, 3) & ": " & c.Offset(0, 1) & " - " & "OUK ID - " & c.Offset(0, 6).Value
OL_TK_i = 0
Set OL = New Outlook.Application
Set OL_NS = Outlook.GetNamespace("MAPI")
Set OL_FL = OL_NS.GetDefaultFolder(olFolderTasks)

If c.Offset.Value = "Y" Then
For Each OL_TK In OL_FL.Items
Select Case UCase(OL_TK.Subject) = UCase(OL_TK_Crit)
Case True
With OL_TK
.DueDate = c.Offset(0, 24).Value
.Save
End With
UP_i = UP_i + 1
OL_TK_i = 1
Exit For
End Select
Next OL_TK

If OL_TK_i = 0 Then
Set OL_TK = OL.CreateItem(olTaskItem)
With OL_TK
.Subject = OL_TK_Crit
.StartDate = c.Offset(0, 23).Value
.DueDate = c.Offset(0, 24).Value
.Body = c.Offset(0, 2).Value
.Companies = c.Offset(0, 3).Value
.ReminderSet = True
.Save
End With
Set OL_TK = Nothing
NE_i = NE_i + 1
End If

Set OL_PF = Nothing
Set OL_NS = Nothing
Set OL = Nothing
End If
If c.Offset.Value = "D" Then
For Each OL_TK In OL_FL.Items
Select Case UCase(OL_TK.Subject) = UCase(OL_TK_Crit)
Case True
With OL_TK
.Delete
End With
DE_i = DE_i + 1
OL_TK_i = 1
Exit For
End Select
Next OL_TK
End If
Next
If UP_i = 0 And NE_i = 0 And DE_i = 0 Then
MsgBox "You have not included anything to create, update or delete" & vbNewLine _
& "Please put a Y or D in the create task/appt column for it to be included", , "Missing Information"
Else
MsgBox "** You have successfully created, updated and deleted tasks **" _
& vbNewLine & vbNewLine _
& NE_i & " tasks created" & vbNewLine & UP_i & " tasks updated" & vbNewLine & DE_i & " tasks deleted", , "Success"
End If
Range("A3").Select
End Sub

CALENDAR APPOINTMENT CREATE/UPDATE/DELETE MACRO :-

Private Sub CommandButton1_Click()
Dim OL As Outlook.Application
Dim OL_AT As Outlook.AppointmentItem
Dim OL_NS As Outlook.Namespace
Dim OL_FL As Outlook.MAPIFolder
Dim OL_AT_Crit As String
Dim OL_AT_i, UP_i, NE_i, DE_i As Integer
Dim w As Workbook
Dim s As Worksheet
Set s = Worksheets("Task Assigner")
Dim c As Range
UP_i = 0
NE_i = 0
DE_i = 0
For i = 3 To s.Range("A2").CurrentRegion.Rows.Count
Set c = s.Cells(i, 1)
OL_AT_Crit = c.Offset(0, 3) & ": " & c.Offset(0, 1) & " - " & "OUK ID - " & c.Offset(0, 6).Value
OL_AT_i = 0
Set OL = New Outlook.Application
Set OL_NS = Outlook.GetNamespace("MAPI")
Set OL_FL = OL_NS.GetDefaultFolder(olFolderCalendar)

If c.Offset.Value = "Y" Then
For Each OL_AT In OL_FL.Items
Select Case UCase(OL_AT.Subject) = UCase(OL_AT_Crit)
Case True
With OL_AT
.End = c.Offset(0, 24).Value
.Save
End With
UP_i = UP_i + 1
OL_AT_i = 1
Exit For
End Select
Next OL_AT

If OL_AT_i = 0 Then
Set OL_AT = OL.CreateItem(olAppointmentItem)
With OL_AT
.Subject = OL_AT_Crit
.Start = c.Offset(0, 23).Value
.End = c.Offset(0, 24).Value
.Body = c.Offset(0, 2).Value
.Companies = c.Offset(0, 3).Value
.Location = "Work"
.Categories = olCategoryColorDarkBlue
.BusyStatus = olBusy
.ReminderSet = True
.ReminderMinutesBeforeStart = 15
.Save
End With
Set OL_AT = Nothing
NE_i = NE_i + 1
End If

Set OL_PF = Nothing
Set OL_NS = Nothing
Set OL = Nothing
End If
If c.Offset.Value = "D" Then
For Each OL_AT In OL_FL.Items
Select Case UCase(OL_AT.Subject) = UCase(OL_AT_Crit)
Case True
With OL_AT
.Delete
End With
DE_i = DE_i + 1
OL_AT_i = 1
Exit For
End Select
Next OL_AT
End If
Next
If UP_i = 0 And NE_i = 0 And DE_i = 0 Then
MsgBox "You have not included anything to create, update or delete" & vbNewLine _
& "Please put a Y or D in the create task/appt column for it to be included", , "Missing Information"
Else
MsgBox "** You have successfully created, updated and deleted appointments **" _
& vbNewLine & vbNewLine _
& NE_i & " appointments created" & vbNewLine & UP_i & " appointments updated" & vbNewLine & DE_i & " appointments deleted", , "Success"
End If
Range("A3").Select
End Sub

Hope to hear soon
 

clarkj5

Thread Starter
Joined
Jan 12, 2011
Messages
6
It does give a run time error and then highlights the first Next OL_AT line in yellow. If you hover over the line the value=nothing.

I wondered if it was because of the amount of calendar entries I have (1500+)

I can post a sample of the spreadsheet if that would help anyone? Thanks
 

clarkj5

Thread Starter
Joined
Jan 12, 2011
Messages
6
I will be able to upload a sample tomorrow

Appreciate the help and interest
 
Status
This thread has been Locked and is not open to further replies. Please start a New Thread if you're having a similar issue. View our Welcome Guide to learn how to use this site.

Users Who Are Viewing This Thread (Users: 0, Guests: 1)

As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 807,865 other people just like you!

Latest posts

Staff online

Top