Попробуйте этот VBa, который я написал для вас ... Обратите внимание, я в Великобритании, поэтому использовал британский формат даты. Приведенный ниже код не предназначен для того, чтобы быть полностью идеальным для ваших нужд (хотя он и делает то, что вы хотите), но он также дает вам отправную точку, чтобы вы могли настроить, как вам нужно.
Sub CreateEvent()
' ==================== UPDATE THE DATES BELOW and add all the public holidays
Dim publicHolidayDates(0 To 1) As Date
publicHolidayDates(0) = "5 / 5 / 2014" ' this is used for demo purposes. The third working day of May is 5th - I've pretended 5th is bank holiday and as such, the event is entered on the 6th
publicHolidayDates(1) = "01/01/2015"
Dim checking As Boolean
checking = True
' ==================== ENTER THE STARTING DATE
Dim myDate As Date
myDate = "1 / 5 / 2014"
Dim dayToCheck As String
Dim dayResult As Integer
Dim thirdDayYet As Integer
thirdDayYet = 0
Dim thirdMonthYet As Integer
thirdMonthYet = 0
' ==================== How many months into the future do you want to add it too (start with 1 just to see it add it to next month)?
Dim numberOfMonthsToAddReminderToo As Integer
numberOfMonthsToAddReminderToo = 2
Do While (checking)
dayToCheck = Format(myDate, "dddd")
If (LCase(dayToCheck) <> "saturday" And LCase(dayToCheck) <> "sunday") Then
Dim canContinue As Boolean
canContinue = True
For i = 0 To UBound(publicHolidayDates)
If publicHolidayDates(i) = myDate Then
canContinue = False
Exit For
End If
Next i
If (canContinue = True) Then
thirdDayYet = thirdDayYet + 1
End If
End If
If (thirdDayYet = 3) Then
SaveToCalender(myDate)
thirdMonthYet = thirdMonthYet + 1
thirdDayYet = 0
myDate = "01/" & month(myDate) & "/" & Year(myDate)
myDate = DateAdd("m", 1, myDate)
End If
If (thirdMonthYet = numberOfMonthsToAddReminderToo) Then
checking = False
End If
myDate = DateAdd("d", 1, myDate)
Loop
End Sub
Sub SaveToCalender(ByVal myDate As Date)
Dim oApp As Outlook.Application
Dim oNameSpace As NameSpace
Dim oItem As AppointmentItem
On Error Resume Next
' check if Outlook is running
oApp = GetObject("Outlook.Application")
If Err <> 0 Then
'if not running, start it
oApp = CreateObject("Outlook.Application")
End If
oNameSpace = oApp.GetNamespace("MAPI")
oItem = oApp.CreateItem(olAppointmentItem)
' ==================== UPDATE THE DETAILS BELOW with the appointment details
With oItem
.Subject = "This is the subject"
.Start = myDate & " 09:00:00"
.Duration = "01:00"
.AllDayEvent = False
.Importance = olImportanceNormal
.Location = "Optional"
.ReminderSet = True
.ReminderMinutesBeforeStart = "10"
End With
oItem.Save()
oApp = Nothing
oNameSpace = Nothing
oItem = Nothing
End Sub
Я добавил несколько комментариев, чтобы вы знали, где можно обновить код для «ваших битов». Надеюсь, все ясно.
Выше может быть значительно улучшено, но это поможет вам. Однако вам нужно будет заметить, что вводимые вами события не синхронизированы, то есть давайте представим, что вы хотите изменить тему события. Вы должны будете сделать это вручную для каждого события в каландре. Он не будет автоматически обновляться.
Вышеизложенное проверено быстро, добавлены события, но могут быть ошибки и т.д., поэтому, пожалуйста, проверьте это сами :)
И снова, прежде чем вы попытаетесь добавить 50 единиц, попробуйте сначала добавить только 1 или 2, чтобы убедиться, что он делает то, что вы хотите!