VBA excel dates to outlook meetings - ignore blank cells

[Yosepht]

Hey everyone,

I'm having a lot of trouble getting my head around VBA and I'm very stuck on this particular issue.
The code does excatly what i need it to, up until " Set RequiredAttendee = .Recipients.Add(Cells(i, 7).Value) " where some of the cells in that range are blank and I need it to ignore and still continue the operation.

I get "Run-Time Error: There must be at least one name or contact group in the To, Cc or Bcc box. Which stops the entire process.

Sorry if this is not how to post a problem as i'm new here.

Public Sub CreateOutlookAppointments()
   Sheets("sheet1").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
        
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
    
    Set olAppt = CalFolder.Items.Add(olAppointmentItem)
    With olAppt
       .MeetingStatus = olMeeting
    'Define calendar item properties
        .Subject = Cells(i, 1)
        .Start = Cells(i, 3)
        .Categories = Cells(i, 4)
        .Body = Cells(i, 5)
        .AllDayEvent = True
        .BusyStatus = olFree
        .ReminderMinutesBeforeStart = 2880
        .ReminderSet = True
' get the recipients
        Dim RequiredAttendee As Outlook.Recipient
        Set RequiredAttendee = .Recipients.Add(Cells(i, 7).Value)
            RequiredAttendee.Type = olRequired
        .Display
    End With
        
        i = i + 1
        Loop
    Set olAppt = Nothing
    Set olApp = Nothing
    
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub
' Above works for meetings but crashes when encountering empty recipient.

 

[Domenic]

Hi, and welcome to MrExcel!

Try the following amendment to your code...

    With olAppt
       .MeetingStatus = olMeeting
    'Define calendar item properties
        .Subject = Cells(i, 1)
        .Start = Cells(i, 3)
        .Categories = Cells(i, 4)
        .Body = Cells(i, 5)
        .AllDayEvent = True
        .BusyStatus = olFree
        .ReminderMinutesBeforeStart = 2880
        .ReminderSet = True
    ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        If Len(theRecipients) > 0 Then
            Dim RequiredAttendee As Outlook.Recipient
            Set RequiredAttendee = .Recipients.Add(theRecipients)
                RequiredAttendee.Type = olRequired
        End If
        .Display
    End With

Hope this helps!

 

[Yosepht]

Thanks so much for your response, Domenic!

This works, however, it continues the function for every blank cell and creates a meeting window. I would like it to completely remove empty cells from the loop so that it doesn't include them when creating meetings. (only appointments that have recipients labelled will be included). Can this be done?

 

[Yosepht]

Sorry, To explain it better, here's the full project I am working on:

I need the reminders in Column A where the attendee slot is filled in Column F to create a meeting window in outlook.

If the attendee cell is blank for an appointment, then I need it to create a regular outlook appointment.

Most importantly, i need the VBA to ignore all empty Cells/Non dates/past dates in Column C for both VBA functions (appointments and meetings).

Any advice on how to do this?

 

[Yosepht]

Focusing on the meeting function for now.

Perhaps if i can add this into the code:

If IsEmpty(Cell) Then
    ' StatementsIfCellIsEmpty
Else
   ' StatementsIfCellIsNotEmpty
End If

It will prevent the olAppt for meetings opening where a blank recipient cell is found. But I don't know if this will work with the looping function when searching for recipients or if it will stop the whole process as soon as an empty cell is found anywhere in that range.

What do you think?

 

[Domenic]

In that case, try the following instead...

    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
        ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        If Len(theRecipients) > 0 Then
            Set olAppt = CalFolder.Items.Add(olAppointmentItem)
            With olAppt
               .MeetingStatus = olMeeting
            'Define calendar item properties
                .Subject = Cells(i, 1)
                .Start = Cells(i, 3)
                .Categories = Cells(i, 4)
                .Body = Cells(i, 5)
                .AllDayEvent = True
                .BusyStatus = olFree
                .ReminderMinutesBeforeStart = 2880
                .ReminderSet = True
            ' get the recipients
                Dim RequiredAttendee As Outlook.Recipient
                Set RequiredAttendee = .Recipients.Add(theRecipients)
                    RequiredAttendee.Type = olRequired
                .Display
            End With
        End If
        i = i + 1
    Loop

Hope this helps!

 

[Yosepht]

That works beautifully at creating meetings using only rows that have a recipient address and prevent crashing when running down outlook's memory opening hundreds of meeting windows! Thank you so much!

The problem I need to tackle now is that it is still bringing up past dates which aren't great when it's sending reminders to my customers. how do make sure only present-day/future dates can set a meeting?

Also, what can I do to properly thank you for your help so far Domenic? :D I've been stuck on this problem for months!

 

[Domenic]

That works beautifully at creating meetings using only rows that have a recipient address and prevent crashing when running down outlook's memory opening hundreds of meeting windows! Thank you so much!

You're very welcome!

The problem I need to tackle now is that it is still bringing up past dates which aren't great when it's sending reminders to my customers. how do make sure only present-day/future dates can set a meeting?

So, if I understood you correctly, you would also like to check the start date in Column C to see whether the date is either today's date or later? If so, try...

    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
        ' get the start date
        Dim startDate As Date
        startDate = Cells(i, 3).Value
        ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        ' check whether the start date is today or later, and whether recipients exist
        If startDate >= Date And Len(theRecipients) > 0 Then
            Set olAppt = CalFolder.Items.Add(olAppointmentItem)
            With olAppt
               .MeetingStatus = olMeeting
            'Define calendar item properties
                .Subject = Cells(i, 1)
                .Start = Cells(i, 3)
                .Categories = Cells(i, 4)
                .Body = Cells(i, 5)
                .AllDayEvent = True
                .BusyStatus = olFree
                .ReminderMinutesBeforeStart = 2880
                .ReminderSet = True
            ' get the recipients
                Dim RequiredAttendee As Outlook.Recipient
                Set RequiredAttendee = .Recipients.Add(theRecipients)
                    RequiredAttendee.Type = olRequired
                .Display
            End With
        End If
        i = i + 1
    Loop

Also, what can I do to properly thank you for your help so far Domenic? :D

You've already done so. Thanks is more than enough.

I've been stuck on this problem for months!

Anytime you have a question, don't hesitate to post your question here on the Board, and one or more of the many talented volunteers here will be happy to help.

Cheers!

 

[Yosepht]

So, if I understood you correctly, you would also like to check the start date in Column C to see whether the date is either today's date or later? If so, try...

That's exactly right, And it works perfectly. I didn't realise all the help here is voluntary, you are beyond legendary my friend!! ?
I honestly can't thank you enough!!!

Here is the full code for anyone else wanting to use it!

Option Explicit
Public Sub CreateOutlookAppointments()
   Sheets("sheet1").Select
    On Error GoTo Err_Execute
    
    Dim olApp As Outlook.Application
    Dim olAppt As Outlook.AppointmentItem
    Dim blnCreated As Boolean
    Dim olNs As Outlook.Namespace
    Dim CalFolder As Outlook.MAPIFolder
    
    Dim i As Long
    
    On Error Resume Next
    Set olApp = Outlook.Application
    
    If olApp Is Nothing Then
        Set olApp = Outlook.Application
         blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    
    On Error GoTo 0
    
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
        
    i = 2
    Do Until Trim(Cells(i, 1).Value) = ""
        ' get the start date
        Dim startDate As Date
        startDate = Cells(i, 3).Value
        ' get the recipients
        Dim theRecipients As String
        theRecipients = Cells(i, 7).Value
        ' check whether the start date is today or later, and whether recipients exist
        If startDate >= Date And Len(theRecipients) > 0 Then
            Set olAppt = CalFolder.Items.Add(olAppointmentItem)
            With olAppt
               .MeetingStatus = olMeeting
            'Define calendar item properties
                .Subject = Cells(i, 1)
                .Start = Cells(i, 3)
                .Categories = Cells(i, 4)
                .Body = Cells(i, 5)
                .AllDayEvent = True
                .BusyStatus = olFree
                .ReminderMinutesBeforeStart = 2880
                .ReminderSet = True
            ' get the recipients
                Dim RequiredAttendee As Outlook.Recipient
                Set RequiredAttendee = .Recipients.Add(theRecipients)
                    RequiredAttendee.Type = olRequired
                .Display
            End With
        End If
        i = i + 1
    Loop
    Set olAppt = Nothing
    Set olApp = Nothing
    
    Exit Sub
    
Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."
    
End Sub

The last thing I've been stuck on with this project is getting appointment-only "reminders" for my calendar.
These will come from the remaining appointments on the same table where there is no recipient. However, I still need to eliminate past dates and the rows where there is a recipient from the operation.

Would it be best to create another sub and have it run the operation separately?

 

[Yosepht]

Is anyone able to help me with the problem i mentioned above?