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.

Adding dates from Excel to Outlook and checking there are no duplicates

Discussion in 'Business Applications' started by zaincmt, Jan 24, 2011.

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

    zaincmt Thread Starter

    Joined:
    Jan 24, 2011
    Messages:
    6
    Hi,

    I am trying to create a Command_click macro that collects the input info for sickness / holiday / appointments in the excel cells then...

    1. Grabs the info from the cells
    2. Checks outlook if the entry already exists
    3. If it doesnt add the entry
    EXAMPLE of excel data

    dateto | datefrom | starttime | endtime | description | location
    25/01/2011 | 26/01/2011 | 08:00 | 15:30 | Dave Smith | holiday
    26/01/2011 | 27/01/2011 | 08:00 | 15:30 | Dave Smith | holiday
    29/01/2011 | 30/01/2011 | 08:00 | 15:30 | John Smith | holiday


    EXAMPLE of macro in excel


    Code:
    Sub CommandButton2_Click()
    
        Dim olApp As Outlook.Application
        Dim olApt As AppointmentItem
        Dim blnCreated As Boolean
        
    'Read the table with appointments:
        Dim arrAppt() As Variant, i As Long
        arrAppt = Range("A2", Cells(Rows.Count, "F").End(xlUp)).Value
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
        If olApp Is Nothing Then
            Set olApp = CreateObject("Outlook.Application")
            blnCreated = True
            Err.Clear
        Else
            blnCreated = False
        End If
        On Error GoTo 0
                
    'Create the outlook item for the table entries:
    'Rows:
    ' Row 1 = date
    ' Row 2 = starttime
    ' Row 3 = endtime
    ' Row 4 = Description
    ' Row 5 = Location
    
        For i = LBound(arrAppt) To UBound(arrAppt)
        Set olApt = olApp.CreateItem(olAppointmentItem)
    
        With olApt
            .Start = arrAppt(i, 1) + arrAppt(i, 3)
            .End = arrAppt(i, 2) + arrAppt(i, 4)
            .Subject = arrAppt(i, 5)
            .Location = arrAppt(i, 6)
            .Body = "Auto excel to outlook sick/holiday/appointment function"
            .BusyStatus = olBusy
            .ReminderMinutesBeforeStart = 5
            .ReminderSet = False
            .Save
        End With
        Next i
    
    
        Set olApt = Nothing
        Set olApp = Nothing
    
    End Sub
    At the moment this works well, it adds all the entries to outlook, but it adds duplicate entries. Please can someone help me.

    Thanks in advance.
     

    Attached Files:

  2. zaincmt

    zaincmt Thread Starter

    Joined:
    Jan 24, 2011
    Messages:
    6
    I have also found a similar code on this forum, which is what i want, but that also does not work (another example attached).

    It has a few issues when checking for entries in outlook appointments and comes across a null value, this seems to create "Object variable or With block variable not set" in the "OL_AT.Subject" and comes up with a mismatch error.

    I have read that this could be due to objects not being referenced properly or if the search finds a null. To get past this, so as i could test if it can still add appointments. I have added the "On Error resume Next" command.

    Code:
        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
            ' >> On Error Resume Next
            Next OL_AT
    Another issue is if i add a new line of info to the excel sheet it does not read that line until i put another line of info below it.

    So my queries are:

    1) How do i get it to stop creating an object variable and mismatch error, when checking for duplicate entries?
    2) How do i get it to read the new row of cell info


    It comes from
    http://forums.techguy.org/business-applications/974240-excel-appointment-task-schedule-update.html

    Code is:
    Code:
    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
    
    
    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, 1) & " - " & c.Offset(0, 2) & "  ||| " & c.Offset(0, 3) & " - " & "JOC 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
            On Error Resume Next
            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
            On Error Resume Next
            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
    
    Private Sub CommandButton2_Click()
        Range("A3:G402").Select
        Selection.ClearContents
        Range("A3").Select
    
    End Sub
    
     

    Attached Files:

  3. zaincmt

    zaincmt Thread Starter

    Joined:
    Jan 24, 2011
    Messages:
    6
    Bump. Any help would be appreciated please.

    Thank you :)
     
  4. zaincmt

    zaincmt Thread Starter

    Joined:
    Jan 24, 2011
    Messages:
    6
    Bump. :) I still need some help please.
     
  5. zaincmt

    zaincmt Thread Starter

    Joined:
    Jan 24, 2011
    Messages:
    6
    Any experts able to help still :) I have issues with the 2nd post in this topic more than the 1st.

    Thank you
     
  6. 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/976663

  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