1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Excel Appointment Task Schedule Update Macro

Discussion in 'Business Applications' started by clarkj5, Jan 12, 2011.

Thread Status:
Not open for further replies.
Advertisement
  1. clarkj5

    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
     
  2. Rollin_Again

    Rollin_Again

    Joined:
    Sep 4, 2003
    Messages:
    4,912
    Are you getting an error or is the macro just not doing anything?

    Rollin
     
  3. clarkj5

    clarkj5 Thread Starter

    Joined:
    Jan 12, 2011
    Messages:
    6
    It stops at the first NEXT OL_AT

    COUNT=0
     
  4. clarkj5

    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
     
  5. Rollin_Again

    Rollin_Again

    Joined:
    Sep 4, 2003
    Messages:
    4,912
    Is there any way you could upload a sample workbook?

    Rollin
     
  6. clarkj5

    clarkj5 Thread Starter

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

    Appreciate the help and interest
     
  7. clarkj5

    clarkj5 Thread Starter

    Joined:
    Jan 12, 2011
    Messages:
    6
    Sample as requested.........
     

    Attached Files:

  8. clarkj5

    clarkj5 Thread Starter

    Joined:
    Jan 12, 2011
    Messages:
    6
    Rollin,

    Any luck with this?

    Cheers
     
  9. Sponsor

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 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/974240

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice