Create Outlook Appointments based on cell info

BScott05 · Jul 3rd 2013

Hello,

I was wanting to create appointments in outlook based on cell's that have a yellow background. Next to each of these cells is a time that these appointments have to be created. I currently have this setup, but the specific cells are hard coded into the macro. This is a very tedious process to setup if i am editing the document and have to move cells around etc..

Is there anyway to create a macro that will look at the activesheet and create the appointments based off the yellow cells and then set the time value that is exactly left of the cell?

here is what i am currently doing...

Code

Sub FE_WEDNESDAY()
    Dim objOL       As Object
    Dim objItem     As Object
    Dim tzCentral   As Object
    
    Set objOL = GetObject(, "Outlook.Application")
    Set tzCentral = objOL.TimeZones.Item("Central Standard Time")
    Set objItem = objOL.CreateItem(1)
    
    intresponse = MsgBox("Do you want to setup " & ActiveSheet.Range("B6") & " reminders?", vbYesNo, "Custom Reminder")
    If intresponse = vbYes Then
   
    '7AM
    Set objItem = objOL.CreateItem(1)
    With objItem
        .Start = (Date) + ActiveSheet.Range("A8").Value
        .StartTimeZone = tzCentral
        .Duration = 0
        .BusyStatus = olFree
        .AllDayEvent = False
        .Subject = ActiveSheet.Range("B8").Value
        .ReminderMinutesBeforeStart = 10
        .ReminderSet = True
        .Save
    End With


    MsgBox "Your strategy reminders have been created for " & Sheets("Admin Menu").Range("H4"), vbOKOnly, "Strategy Reminder"
    
    ElseIf intresponse = vbNo Then
Exit Sub
    
    Set objItem = Nothing
    Set objOL = Nothing
    Set tzEastern = Nothing
    
    End If
End Sub

Display More

If i need to elaborate or say further detail, i am more than happy too..

Thank you for the help!

John_w · Jul 3rd 2013

Re: Create Outlook Appointments based on cell info

Not the full solution, but see if you can incorporate the following code into your code. It loops through the yellow cells in the active sheet and outputs the value of the cell to the left.

Code

Sub yellow_cells()
    Dim cell As Range
    For Each cell In ActiveSheet.UsedRange
        If cell.Interior.ColorIndex = 6 Then 'yellow
            Debug.Print cell.Offset(0, -1).Value
        End If
    Next
End Sub

BScott05 · Jul 3rd 2013

Re: Create Outlook Appointments based on cell info

Thank you for the help!

so i tried plugging the code in above to fit my question.. and it basically loops constantly and wotn stop creating appointments..

Code

Sub TEST_APPT()


    Dim objOL       As Object
    Dim objItem     As Object
    Dim tzCentral   As Object
    Dim cell As Range
    
    Set objOL = GetObject(, "Outlook.Application")
    Set tzCentral = objOL.TimeZones.Item("Central Standard Time")
    Set objItem = objOL.CreateItem(1)
    
    
    For Each cell In ActiveSheet.UsedRange
    If cell.Interior.ColorIndex = 6 Then 'yellow
        Set objItem = objOL.CreateItem(1)
            With objItem
             .Start = (Date) + ActiveSheet.Range("A8").Value
             .StartTimeZone = tzCentral
             .Duration = 0
             .Body = "Strategy Document link: [URL="http://team.usaa.com/sites/bank/cstratgy/Run%20Library/MDS%20Strategy%20Document.xlsm"]http://team.usaa.com/sites/bank/cstratgy/Run%20Library/MDS%20Strategy%20Document.xlsm[/URL]"
             .BusyStatus = olFree
             .AllDayEvent = False
             .Subject = ActiveSheet.Range("B8").Value
             .ReminderMinutesBeforeStart = 10
             .ReminderSet = True
             .Display
            End With
    End If
    Next
        
    For Each cell In ActiveSheet.UsedRange
    If cell.Interior.ColorIndex = 6 Then 'yellow
        Set objItem = objOL.CreateItem(1)
            With objItem
             .Start = (Date) + ActiveSheet.Range("A8").Value
             .StartTimeZone = tzCentral
             .Duration = 0
             .Body = "Strategy Document link: [URL]http://team.usaa.com/sites/bank/cstratgy/Run%20Library/MDS%20Strategy%20Document.xlsm[/URL]"
             .BusyStatus = olFree
             .AllDayEvent = False
             .Subject = ActiveSheet.Range("B8").Value
             .ReminderMinutesBeforeStart = 10
             .ReminderSet = True
             .Display
            End With
    End If
    Next
        
        MsgBox "Your strategy reminders have been created for " & Sheets("Admin Menu").Range("H4"), vbOKOnly, "Strategy Reminder"
    
    
    Set objItem = Nothing
    Set objOL = Nothing
    Set tzEastern = Nothing
    
End Sub

Display More

Maybe this would be easier to do.. I want to select all the cells that are yellow (color 6 on the index) and create an appointment for each cell that is selected and set the time based on the cell exactly 1 cell to the left of the selected cell...Would that be easier to do?

Create Outlook Appointments based on cell info

Participate now!

Share