Excel/VBA Creating Outlook Appointments from Spreadsheet Data

[Sbar47]

I'm trying to create a macro that will create appointments based on task from column B. For some reason, my code to create appointments is creating each item in the subfolder twice.
Also, I'm trying to get the appointment date to be column F -30 days. Ultimately I would like to have this macro be able to update appointments if the date in column F is different then whats been created. As this spreadsheet will be updated weekly and the date in column F could change. Thank you for the help!


I tried

<code style="margin: 0px; padding: 1px 5px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; font-size: 13px; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; background-color: rgb(239, 240, 241); white-space: pre-wrap;">oAppt.Start = cell(0, 6).value -30.

</code>

Sub CreateAppointment()
Dim ws As Worksheet
Dim subfolders() As String
Dim cell As Range, i As Integer
Dim oAppt As AppointmentItem


subfolders = Split("UGD GAS,FOUNDATION REDESIGN", ",")


Application.ScreenUpdating = False


For Each ws In ActiveWorkbook.Worksheets
        For Each cell In ws.Range("B1:B100") 'Changing this cell range to a smaller, defined range will improve performance
            For i = LBound(subfolders) To UBound(subfolders)
                If cell.Value = subfolders(i) Then
        Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)


        oAppt.Subject = cell.Value
        oAppt.Start = Date - 30
        oAppt.Save
                End If
            Next i
        Next cell
    Next


Application.ScreenUpdating = True


End Sub

A sample of my spreadsheet

https://drive.google.com/open?id=1o74ZFwL4IbXt_U45dRp38Kj_DTFqp3B7

 

[Sbar47]

i got the code to work using

[FONT=&quot]Sub CreateAppointment() Dim ws As Worksheet Dim subfolders() As String Dim cell As Range, i As Integer
Dim oAppt As AppointmentItem Dim lr As Long Dim j As Integer subfolders = Split("UGD GAS,FOUNDATION REDESIGN", ",") Application.ScreenUpdating = False Set ws = ActiveWorkbook.ActiveSheet With ws 'Get lr lr = .Cells(.Rows.Count, 2).End(xlUp).Row For j = 2 To lr '(Assuming your data starts on row 2) For i = LBound(subfolders) To UBound(subfolders) If .Cells(j, 2).Value = subfolders(i) Then Set oAppt = Outlook.Application.CreateItem(olAppointmentItem) oAppt.Subject = .Cells(j, 2).Value oAppt.Start = .Cells(j, 6).Value - 30 & " 12:00:00" oAppt.Save End If Next i Next j End With Application.ScreenUpdating = True End Sub

[/FONT]Still trying to figure out a way to search the appointments by subject, and if dates differ it will update appointment instead of creating another! thanks for the help.