Clever-Excel-Forum

Hallo zusammen,

ich habe eine Frage bezüglich eines Makros, mit dem man Termine aus einer Excel Tabelle in Outlook importieren kann.
Mit dem folgenden Code funktioniert es bereits, dass durch das drücken auf eine Schaltfläche alle darin enthaltenen Termine in Outlook exportiert werden.

Code:
Sub createAppointments()

    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.Stores.Item("test@test.de").GetDefaultFolder(9).Folders.Item("Excel Test")

    Set sheet = Worksheets("Termine")

    Set rngStart = sheet.Range("A2")

    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

            strLocation = cell.Offset(0, 6).Text

            strComment = cell.Offset(0, 7).Text

            boolReminderSet = cell.Offset(0, 8).Value = True

            'Eventuelles Duplikat des Termins finden ---------

            Set allItems = objCal.items

            allItems.Sort "[Start]"

            ' Ganztagestermin oder normaler Termin unterscheiden

            If boolAllDay = True Then

                ' Filtere Termine nach Ganztagesevents zu dieser Zeit und dem Betreff

                Set dupe_item = allItems.Restrict("[Start]=""" & Format(strStartDate, "dd.mm.yyyy hh:mm") & """ AND [END]= """ & Format(DateAdd("d", 1, DateValue(strEndDate)), "dd.mm.yyyy hh:mm") & """ AND [Subject] = '" & strSubject & "' AND [AllDayEvent] = True")

            Else

                ' Filtere normale Termine zu dieser Zeit und dem Betreff

                Set dupe_item = allItems.Restrict("[Start]=""" & Format(strStartDate, "dd.mm.yyyy" & strStartTime, "hh:mm") & """ AND [END]= """ & Format(strEndDate, "dd.mm.yyyy" & strEndTime, "hh:mm") & """ AND [Subject] = '" & strSubject & "' AND [AllDayEvent] = False")

            End If

            ' hole den ersten passenden Termin wenn er exisitiert

            Set itm = dupe_item.GetFirst

            If itm Is Nothing Then

                ' erstelle neuen Termin wenn kein Duplikat exisitert

                Set olApp = objCal.items.Add(1)

            Else

                ' verwende den gefundenen Termin

                Set olApp = itm

            End If

            With olApp

                .Location = strLocation

                .ReminderSet = boolReminderSet

                .Subject = strSubject

                .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

                    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

            Set olApp = Nothing

        Next

        Set objOL = Nothing

        MsgBox counter & " Termin(e) wurde(n) erstellt!", vbInformation

    End Sub

Mir fehlen allerdings noch drei Funktionen, bei denen ich leider nicht weiß wie ich diese umsetzen kann.

- Duplikate sollen geändert und nicht nochmal hinzugefügt werden

- Jeder Termin soll einzeln dem Kalender hinzugefügt werden können

- Termine löschen

Ich hoffe jemand kann mir weiterhelfen und weiß, wie man so etwas implementieren kann.

Viele Grüße
Jan

Hallöchen,

schaue mal, ob das schon helfen kann. Da hab ich z.B. doppelte Eintragungen verhindert

Ampelfunktion-mit-Email-oder-Outlookkalender-verbinden?pid=177601#pid177601

Hi Jan,

(21.09.2020, 08:54)Jan1403 schrieb: [ -> ]Mir fehlen allerdings noch drei Funktionen, bei denen ich leider nicht weiß wie ich diese umsetzen kann.
- Duplikate sollen geändert und nicht nochmal hinzugefügt werden
- Jeder Termin soll einzeln dem Kalender hinzugefügt werden können
- Termine löschen

Ich hoffe jemand kann mir weiterhelfen und weiß, wie man so etwas implementieren kann.

Dies ist ein interessantes Thema und ich habe es vorletzte Woche auch schon versucht, hatte dann aber keine Zeit mehr.
Nun werde ich Dein Makro mal testen.

Ich habe noch eine Funktion, die ich gerne hätte:
- Terminserien, also z.B. Import einer Geburtstagsliste

Hat jemand damit auch schon experimentiert oder das umgesetzt?

Gruß Ralf

Hi Ralf,

bei mir war das glaube eine Terminserie, auch mit Anfang und Ende ...

Jan1403

schauan

Rabe

schauan