none
Previously working VBA Code is not working now - WHY? (code makes outlook appointments from dates in excel spreadsheet) RRS feed

  • Question

  • Below is code (written by another - and *note* I am not fluent in VBA code language) that I had to add column identifiers to the code to accommodate a change in the worksheet (additional columns were added) another employee had made.  But even before I made these edits to the code, the code wasn't working as it had previously.  I noticed it did not create an appointment when a new row was added - this is before I changed the columns the code is suppose to look at.

    here is the code:

    Option Explicit
    Sub AddToTxkaOutlookCalendar()
    '!! ********Reference to Outlook object library required -- TOOLS, REFERENCE, OUTLOOK ##!!*************
      Dim olAppointment As Outlook.AppointmentItem
      Dim olApptSearch As Outlook.AppointmentItem
      Dim olApp As Outlook.Application
      Dim olFolder As Object
      Dim LR As Long, ws As Worksheet
      Dim NS As Outlook.Namespace
      Dim colItems As Outlook.Items
      Dim Appfound As Boolean
      Dim MyCal As String
      Dim UseDate As Date
      Dim Col As Variant
      Dim Rng As Range, cel As Range
      Dim x As Long
      Dim LastEmplRow As Long  '********<---Add this Line*****************

      'Get reference to MS Outlook Object Library*************************
      On Error Resume Next
      Set olApp = GetObject(, "Outlook.Application")
      If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
      End If

      MyCal = "Renewal Dates"   ' change your CALENDAR name here *********
      Set NS = olApp.GetNamespace("MAPI")
      Set olFolder = NS.GetDefaultFolder(olFolderCalendar)
      On Error Resume Next
      Set olFolder = olFolder.Folders(MyCal)
      On Error GoTo 0
      Set ws = Sheets("MASTER") ' change your "WORKSHEET" name here ******

      With ws
        .AutoFilterMode = False
        LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                         SearchDirection:=xlPrevious).Row
        LastEmplRow = .Range("B12").End(xlDown).Row '<---Add this Line*  ************************************
        For Each Col In Array("F", "M", "N", "O", "P", "Q", "R", "S", "U", "W", "X") ' these are the COLUMNS you want apptmts for************
          .Range(Col & "12:" & Col & LR).AutoFilter Field:=1, Criteria1:="<>-", Operator:=xlAnd, Criteria2:="<>x"
         
          x = .Range(.Cells(10, Col), .Cells(LastEmplRow, Col)).SpecialCells(xlCellTypeVisible).Count - 2 'first # is header row
        
       
          If x >= 1 Then
          For Each cel In .Range(.Cells(12, Col), .Cells(LastEmplRow, Col)).SpecialCells(xlCellTypeVisible)  ' FIRST # IS ROW TO START, SECOND IS LAST ROW TO EXAMINE
          Appfound = False
              Set olAppointment = olFolder.Items.Add
              UseDate = DateAdd("yyyy", 1, cel.Value)
              With olAppointment
                .Subject = ws.Cells(cel.Row, "C").Value & " - " & ws.Cells(10, Col).Value  ' CHANGE TO CORRECT COLUMN LTR AND HEADER ROW
                .Location = ws.Cells(10, Col).Value ' CHANGE # TO HEADER ROW
                .Start = UseDate
                .AllDayEvent = True
                .Body = (UseDate - 365) & " " & ws.Cells(cel.Row, "C").Value & " - " & ws.Cells(10, Col).Value
                .ReminderMinutesBeforeStart = 20160  'remind 2 weeks in advance (1440 min./day - 60minx24hrs)
                .ReminderSet = True
                Set colItems = olFolder.Items
                For Each olApptSearch In colItems
                  If olApptSearch.Subject = olAppointment.Subject And _
                     olApptSearch.Location = olAppointment.Location _
                     And olApptSearch.Start = olAppointment.Start Then Appfound = True
                Next
                If Appfound = False Then
                  .Save
                Else
                End If
              End With
              Set olAppointment = Nothing
            Next cel
          End If
          ws.AutoFilterMode = False
        Next Col
      End With
    End Sub

    HELP!

    Wednesday, June 7, 2017 1:43 PM

All replies

  • Hard to say, but make sure that you don't have any blank cells in column B.

    This line can return the wrong last row if any cell in B is blank.

    LastEmplRow = .Range("B12").End(xlDown).Row

    In general, this is better at finding the last row:

    LastEmplRow = .Cells(.Rows.Count,"B").End(xlUp).Row

    But, LR and LastEmplRow should be the same..... not sure why the code uses two values instead of one....

    Wednesday, June 7, 2017 7:44 PM
  • Hello,

    Would you get any error? What is the result if you run the macro? 

    According to the code, i do not think it would create an appointment when a new row was inserted. That could be done in the Worksheet_change event. Your code is getting the last empty row and loop through one column to insert appointment based on cell value.

    I would suggest you watch the LastEmplRow and run step by step to check if the line to create appointments would execute.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Tuesday, June 13, 2017 8:11 AM
    Moderator
  • thank you!  This has me on the right track.

    The LastEmplRow = .Range("B12").End(xlDown).Row is needed because I only want the employees of a certain company to be created in Calendar. I currently have about 38 companies (up to 400 rows right now), but only want the first company in spreadsheet to create appointments in Outlook Calendar (right now they are contained in rows 12-42 (of course it fluctuates as the company adds employees to the list).

    I did changed it to the coding you stated and it is giving me the info I needed on new employees added within the desired company but of course it is creating appointments for ALL the company/employees on the spreadsheet.

    Any additional suggestions?

    I am not receiving any errors.  The code processes as normal, but new appointments are not created for any new employee added or any dates that have been updated within the spreadsheet. It performed correctly for about a year, so not sure what happened to cause the issue.

    Thursday, July 13, 2017 1:56 PM
  • I am not receiving any errors.  The code processes as normal, but new appointments are not created for any new employee added or any dates that have been updated within the spreadsheet. It performed correctly for about a year, so not sure what happened to cause the issue.

    Thursday, July 13, 2017 1:56 PM
  • Hello,

    I suggest you press F8 to run the macro step by step and you could add watch by righting clicking the Watches windows. To check the value of LR, LastEmplRow, Col and x. Since you didnt get any error but the it could not create the appointment, i think it is because your x is never bigger than 1.

    If you have no idea about debugging, i suggest you share your workbook here. You could upload your file into OneDrive and share the link here.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, July 14, 2017 7:20 AM
    Moderator