Tech Support Guy banner
Status
Not open for further replies.
1 - 8 of 8 Posts

·
Registered
Joined
·
6 Posts
Discussion Starter · #1 ·
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
 

·
Registered
Joined
·
6 Posts
Discussion Starter · #4 ·
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
 
1 - 8 of 8 Posts
Status
Not open for further replies.
Top