Ohne Doppelnennungen Kalendereintrag aus Excel
10.09.2015 15:58:31
Marcel
Ich brauche Hilfe bei der Umsetzung eines Makros.
Ich habe eine Task List, bei welcher ich anhand eines Makros die Verschiedenen Aufgaben gemäss Zuständigkeit auf einzelne Arbeitsblätter verteilen.
In einem weiteren Schritt, werden die Aufgabe des jeweiligen Arbeitsblattes über einen Button im Outlookkalender eingetragen. Soweit so gut, bis hier hin klappt alles.
Mein Problem liegt darin, dass alle Aufgaben jedes mal wenn ich auf den Button klicke im Outlook eingetragen werden. Ich möchte jedoch doppelt eingetragene Termine vermeiden, da die Task List fortlaufend ergänzt wird und ich dann nur die neuen Einträge im Outlook eintragen möchte.
Unter http://www.ms-office-forum.net/forum/archive/index.php?t-270088.html fand ich einen guten Code mit welchem es möglich ist, in einem gewissen Zeitraum Kalendereinträge von Outlook abzufragen. Leider schaffe ich es nicht die einzelnen Daten mit den jeweiligen Daten aus meinem Excel zu vergleichen und dann entweder den Eintrag zu erstellen oder zu überspringen.
Ich hoffe, dass ich mich genug verständlich ausdrücken konnte und dass mir jemand weiterhelfen kann.
Vielen Dank schon mal im Voraus.
Marcel
Folgend mein Code den ich ergänzen mögchte und meine Task-List:
https://www.herber.de/bbs/user/100119.xlsm
Public Sub create_Appointments2(shtName)
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objCal = objOL.Session.GetDefaultFolder(9)
Set shtTemplate = ThisWorkbook.Worksheets(shtName)
Set rngStart = shtTemplate.Range("A2")
If IsEmpty(Range("A3")) Then
Set rngEnd = rngStart
Else
Set rngEnd = rngStart.End(xlDown)
End If
counter = 0
For Each cell In shtTemplate.Range(rngStart, rngEnd)
Set olApp = objCal.items.Add(1)
With olApp
'H & i Text im Kalender
.Body = "Massnahme: " & cell.Offset(0, 4).Text & "INFO/NOTIZ: " & cell.Offset(0, 8). _
_
Text
'a Thema
strSubject = cell.Offset(0, 3).Text
'B End Datum als Anfangsdatum
strStartDate = cell.Offset(0, 6).Text
'B gleich wie Start
strEndDate = cell.Offset(0, 6).Text
'F
boolAllDay = cell.Offset(0, 9).Value
'G
strCategory = cell.Offset(0, 10).Text
.Subject = strSubject
.ReminderSet = False
If strCategory "" Then
.Categories = strCategory
End If
If boolAllDay = True Then
.AllDayEvent = True
If IsDate(strStartDate) Then
.Start = DateValue(strStartDate)
.End = DateAdd("d", 1, DateValue(strStartDate))
.Save
counter = counter + 1
Else
MsgBox "Termin mit dem Betreff: '" & strSubject & "' in Zeile " & cell.Row & _
_
" hat ungültige oder fehlende Zeitangaben", vbExclamation
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
Else
MsgBox "Termin mit dem Betreff: '" & strSubject & "' in Zeile " & cell.Row & _
_
" hat ungültige oder fehlende Zeitangaben", vbExclamation
End If
End If
End With
Next
Set objOL = Nothing
MsgBox counter & " Termin(e) wurden erstellt!", vbInformation
End Sub
Sub Start_name1()
shtName = ActiveSheet.Name
Call create_Appointments2(shtName)
End Sub