Mit Makro aus Tabelle Kalendereintrag erstellen ohne Doppelnennungen

[bbbunny]

Hallo Zusammen,

Ich suche nach einer Lösung, anhand welcher ich Massnahmen aus einem Excel-Massnahmenplan in den Outlook-Kalender einfügen kann.
Mithilfe von diversen Forenbeiträgen, habe ich meinen Massnahmenplan soweit gebracht, dass ich anhand eines Makros die Einzelnen Aufgaben gemäss Verantwortlichen Person auf separaten Tabellenblätter bereitstellen kann.
Nun möchte ich dass ich diesen Plan verschicken kann und die jeweilig Person, anhand eines Button die Massnahmen in den eigenen Kalender übertragen können.
Auf einem Test-Excel hat das alles schon gut geklappt, jedoch habe ich den Code direkt in das Tabellenblatt geschrieben und nicht in das Modul. Wenn ich nun den Text in ein Modul kopiere, funktioniert Garnichts mehr.

Kann mir jemand weiterhelfen? ich versuchte Den Code mit ActiveSheet für alle Tabellenblätter zugänglich zu machen, leider ohne Erfolg.

Da ich durch mein erstes Makro neue Tabellenblätter erstelle, kann ich das zweite Makro leider nicht Tabellenblatt abhängig machen (glaube ich...).

Zusätzlich versuchte ich eine Funktion einzubauen, mit welcher ich nur Termine im Kalender eintrage, die noch nicht vorhanden sind. Dementsprechend möchte ich doppelte Einträge vermeiden. Aber hier bin ich kläglich gescheitert.

Ich hoffe, dass ich mich klar genug ausgedrückt habe wo der Schuh drückt :16:.

Für ein besseres Verständnis folgt mein Code und im Anhang mein Massnahmenplan.

Vielen Dank schon im Voraus.

Code:

Sub create_Appointments()
   
   On Error Resume Next
   Set objOL = CreateObject("Outlook.Application")
   Set objCal = objOL.Session.GetDefaultFolder(9)
   '
   Set Sheet = Active.Sheet
   '
   Set rngStart = Sheet.Range("A2")
   If IsEmpty(Range("A3")) Then
   Set rngEnd = rngStart
   
   Else
   Set rngEnd = rngStart.End(xlDown)
   End If
   counter = 0
   For Each cell In Sheet.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

 Aus dem Beispiele & Workshops-Forum hierher verschoben
Moderator [Bild: Ameise.gif]

[Kl@us-M.]

Nach oben geholt