Termine nach Outlook senden aber ohne Duplikate
01.11.2018 22:36:33
Eppacher
ich habe ein Makro, mit dem ich die Termine aus dem Excel ins Outlook übertragen kann.
Eine wichtige Funktion fehlt und zwar:
Beim Importieren der Termine sollen alle Termine der grünen Kategorie durch die neuen Termine ersetzt werden. In der jetzigen Version wird der Betreff der Termine verglichen. Ändert sich der Text wird ein neuer Termin angelegt.
hier der Code, den ich benutze (es sind einige Absätze eingefügt):
Sub Termine_nach_Outlook()
On Error Resume Next
Dim sheet As Worksheet, rngStart As Range, rngEnd As Range, cell As Range
Set objOL = CreateObject("Outlook.Application")
Set objCal = objOL.Session.GetDefaultFolder(9)
Set sheet = Worksheets(1)
Set rngStart = sheet.Range("G4")
Set rngEnd = rngStart.End(xlDown)
counter = 0
For Each cell In sheet.Range(rngStart, rngEnd)
strSubject = cell.Text
strStartDate = cell.Offset(0, 1).Text
strStartTime = cell.Offset(0, 2).Text
strEndDate = cell.Offset(0, 3).Text
strEndTime = cell.Offset(0, 4).Text
boolAllDay = cell.Offset(0, 5).Value
strCategory = cell.Offset(0, 6).Text
strComment = cell.Offset(0, 7).Text
'Eventuelles Duplikat des Termins finden ---------
Dim dupe_item As Object, itm As Object
If boolAllDay Then
Set dupe_item = objCal.items.Restrict("[Start] = """ &
Format(strStartDate, "ddddd") & " 12:00 AM"" AND [END] = """ & Format
(DateAdd("d", 1, DateValue(strEndDate)), "ddddd") & " 12:00 AM"" AND
[Subject] = '" & strSubject & "'")
Else
Set dupe_item = objCal.items.Restrict("[Start] = """ &
Format(strStartDate & " " & strStartTime, "ddddd hh:nn") & """ AND [END] = """ &
Format(strEndDate & " " & strEndTime, "ddddd hh:nn") & """ AND [Subject] = '" &
strSubject & "'")
End If
Set itm = dupe_item.GetFirst
Set olApp = IIf(itm Is Nothing, objCal.items.Add(1), itm)
With olApp
.Subject = strSubject
.ReminderSet = False
If strCategory "" Then
.Categories = "Grüne Kategorie"
End If
.Body = strComment
If boolAllDay = True Then
.AllDayEvent = True
If IsDate(strStartDate) Then
.Start = DateValue(strStartDate)
.End = DateAdd("d", 1, DateValue(strStartDate))
.Save
counter = counter + 1
End If
Else
.AllDayEvent = False
If IsDate(strStartDate) And IsDate(strEndDate) And
IsDate(strStartTime) And IsDate(strEndTime) Then
.Start = DateValue(strStartDate) & " " & TimeValue(strStartTime)
.End = DateValue(strEndDate) & " " & TimeValue(strEndTime)
.Save
counter = counter + 1
End If
End If
End With
Next
Set objOL = Nothing
MsgBox counter & " Einträge erstellt", vbInformation
End Sub
Liebe Grüße Eppacher