VBA- import dates into excel calendar via button help- also do not reimport already imported items

[MorganB]

Hello,
I am struggling with a new spread sheet for tracking our jobs per year.
I have created a workbook with the sheets- JOBS,CALENDAR,JAN,FEB,MAR,APRIL ETC

In the CALENDAR sheet it has the following Info that i want it to import straight into outlook calendar.
start date- description- Location- Body : Are the 4 rows of info I would like to import directly into calendar as meetings

I would also like it to not import repeats as we enter new jobs in a daily basis. The Description should never change.

I have tried copying vba code of various threads and modifing it but but nothing I do seems to work. i think I have seen every error there is.
I am familiar with code but cannot write my own confidently,
I have spent hours trying to upskill myself to get this to work but I cannot.

Also how do I get this formula to show nothing when it has a zero value?? is it possible
=("Install"&"-"&JOBS!B4&"- "&JOBS!C4&"- "&JOBS!D4&"- "&JOBS!F4&"- "&JOBS!G4&"- "&JOBS!H4&"- "&JOBS!I4&+" - "&JOBS!N4)

Any help would be greatly appreciated.

 

[bobsan42]

about the Calendar:
I have not dealt with this subject so far and I cannot really spare too much time right now.
Do you have some code compilation which you think is the closest to what you need?

about the formula:
IMO you have several (three) options - the choice will depend on what you really need to achieve - a cell with a zero length value or a cell which appears to be blank:
- use an IF statement: =IF([your_formula]= 0,"",[your_formula]) - however this will make excel calculate the formula twice which is not ideal
- (my preferred option) use custom number formatting for the cell in question (adjust as needed for the numbers you expect to have): #;-#;?;
- use conditional formatting: set the font color to match the fill color when the value is 0

 

[MorganB]

this was a code i found but it does not work

Option Explicit
Public Sub CreateOutlookApptz()
Sheets("CALENDAR").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 subFolder As Outlook.MAPIFolder
Dim arrCal As String

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) = ""
arrCal = Cells(i, 1).Value
Set subFolder = CalFolder.Folders(arrCal)
If Trim(Cells(i, 11).Value) = "" Then
Set olAppt = subFolder.Items.Add(olAppointmentItem)

'MsgBox subFolder, vbOKCancel, "Folder Name"

With olAppt

'Define calendar item properties
.Start = Cells(i, 6) + Cells(i, 7) '+ TimeValue("9:00:00")
.End = Cells(i, 8) + Cells(i, 9) '+TimeValue("10:00:00")



.Subject = Cells(i, 2)
.Location = Cells(i, 3)
.Body = Cells(i, 4)
.BusyStatus = olBusy
.ReminderMinutesBeforeStart = Cells(i, 10)
.ReminderSet = True
.Save

End With
Cells(i, 11) = "Imported"

End If

i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
ThisWorkbook.Save
Exit Sub

Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."

End Sub

this is the other I found

Sub RegisterAppointmentList()
‘ adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long

On Error Resume Next
Worksheets("Schedule").Activate


Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
r = 6 ‘ first row with appointment data in the active worksheet
Dim mysub, myStart, myEnd
While Len(Cells(r, 2).Text) <> 0
mysub = Cells(r, 2) & ", " & Cells(r, 3)
myStart = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value
myEnd = DateValue(Cells(r, 5).Value) + Cells(r, 7).Value
‘DeleteTestAppointments mysub, myStart, myEnd
Set olAppItem = olApp.CreateItem(olAppointmentItem) ‘ creates a new appointment
With olAppItem
‘ set default appointment values
.Location = Cells(r, 3)
.Body = ""
.ReminderSet = True
.BusyStatus = olFree
‘.RequiredAttendees = "johndoe@microsoft.com"
On Error Resume Next
.Start = myStart
.End = myEnd
.Subject = Cells(r, 2) & ", " & .Location
.Attachments.Add ("c:\temp\somefile.msg")
.Location = Cells(r, 3).Value
.Body = .Subject & ", " & Cells(r, 4).Value
.ReminderSet = True
.BusyStatus = olBusy
.Categories = "Orange Category" ‘ add this to be able to delete the testappointments
On Error GoTo 0
.Save ‘ saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
MsgBox "Done !"
End Sub