08.11.2018, 15:56
Hallo zusammen,
ich hoffe ihr könnt mir mal wieder helfen.
Bisher habe ich aus Excel meine Termine aus einer Tabelle heraus nach Outlook übertragen - das funktionierte auch super - dank Eurer Hilfe
Um bei begrenzten Termin-Abfolgen nicht immer alle einzelnen Termine in der Tabelle auflisten zu müssen würde ich das gerne mit "einem" Datensatz machen.
Die Tabelle könnte dann ev. so aufgebaut werden:
Tabelle5
Folgendes Makro habe im Netz für sich jährlich wiederholende Termine gefunden:
Könntet Ihr mir einen Tipp geben wie das zu ändern wäre um zeitlich begrenzte Serien-Termine, also von Datum-Start bis Datum-Stopp im wöchentlichen oder monatlichem Raster in Outlook abgebildet werden könnte.
Vielen Dank für Eure Hilfe!
ich hoffe ihr könnt mir mal wieder helfen.
Bisher habe ich aus Excel meine Termine aus einer Tabelle heraus nach Outlook übertragen - das funktionierte auch super - dank Eurer Hilfe
Um bei begrenzten Termin-Abfolgen nicht immer alle einzelnen Termine in der Tabelle auflisten zu müssen würde ich das gerne mit "einem" Datensatz machen.
Die Tabelle könnte dann ev. so aufgebaut werden:
Tabelle5
| D | E | F | G | H | I | J | K | L | |
| 5 | Subject | Start | Ende | Location | Color-ID | ||||
| 6 | Betreff | Beginntam | Endet am | Terminraster | Serientermin | Beginn | Endetum | ||
| 7 | Betreff | 01.05.2018 | 30.09.2018 | wöchentlich/monatlich | ja / nein | 18:00 | 120 | Hier | Gelbe Kategorie |
| Excel-Inn.de |
| Hajo-Excel.de |
| XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007 |
| Add-In-Version 21.08 einschl. 64 Bit |
Folgendes Makro habe im Netz für sich jährlich wiederholende Termine gefunden:
Könntet Ihr mir einen Tipp geben wie das zu ändern wäre um zeitlich begrenzte Serien-Termine, also von Datum-Start bis Datum-Stopp im wöchentlichen oder monatlichem Raster in Outlook abgebildet werden könnte.
Code:
Option Explicit
Sub Einfügen()
'adds a list of appontments to the Calendar in Outlook
Dim OLApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim OutApp As Object, apptOutApp As Object, oApp As Object, oAddr As Object, opattern As Object
Dim OutPattern As RecurrencePattern
Dim datStart As Date
Dim endRow As Long
Dim wsSenden As Worksheet
Dim row As Long
Const startRow As Long = 6
Dim Zeile As Long, Zeile1 As Long, Suchbegriff As Long
Zeile = Range("A65536").End(xlUp).row
Set oApp = CreateObject("outlook.application")
Set oAddr = oApp.CreateItem(olAppointmentItem)
Set wsSenden = ThisWorkbook.Worksheets("Serientermine")
endRow = Zeile
On Error Resume Next
Set OLApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If OLApp Is Nothing Then
On Error Resume Next
Set OLApp = GetObject("Outlook.Application")
On Error GoTo 0
If OLApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
For row = startRow To endRow
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem)
With apptOutApp
' set default appointment values
.MeetingStatus = olMeeting
.AllDayEvent = True
'.End = Now
.Subject = "No subject"
.Location = " "
.Body = ""
.ReminderSet = True
' read appointment values from the worksheet
On Error Resume Next
.Start = Cells(row, 3).Value '+ Cells(row, 5).Value
'.End = Cells(row, 7).Value '+ Cells(row, 8).Value
.Subject = Cells(row, 1).Value
.Location = Cells(row, 13).Value
.Body = Cells(row, 11).Value
.Resources = Cells(2, 10).Value
.ReminderMinutesBeforeStart = 720
'mit Sound
.ReminderPlaySound = True
Set OutPattern = apptOutApp.GetRecurrencePattern
OutPattern.RecurrenceType = olRecursYearly ' wiederkehrender Termin
.Duration = 1440
On Error GoTo 0
'.Save ' saves the new appointment to the default folder
.Save
End With
Next
Set olAppItem = Nothing
Set OLApp = Nothing
Set wsSenden = Nothing
MsgBox "Termine wurden generiert"
End SubVielen Dank für Eure Hilfe!
![[-]](https://www.clever-excel-forum.de/images/collapse.png)
