Termine aus Excel in Outlook übertragen ?

Sub Termin_nach_Outlook() 'Verweis auf Microsoft Outlook x.x Object Library muss gesetzt sein 'Gehe auf EXTRAS / VERWEIS und suche die entsprechende Library Dim OutApp As Object, apptOutApp As Object 'Hier beginnen die Termine Range("B2").Select Do Until ActiveCell.Value = "" Set OutApp = CreateObject("Outlook.Application") Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem) With apptOutApp 'Datum und Uhrzeit .Start = Format(ActiveCell.Value, "dd.mm.yyyy") & " 08:00" 'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen 'Termininfo .Subject = "Geburtstag von: " & ActiveCell.Offset(0, -1).Value 'oder der Betreff steht in der Spalte rechts von den Terminen 'Zusätzlicher Text .Body = "" 'ort .Location = "geboren am:" & " " & ActiveCell.Offset(0, 0).Value .Duration = "5" 'Erinnerung .ReminderMinutesBeforeStart = 10 'mit Sound .ReminderPlaySound = True 'Erinnerung wiederholen .ReminderSet = True .Categories = "Geburtstage" 'Termin speichern .Save End With 'Nächste Zelle auswählen ActiveCell.Offset(1, 0).Select 'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal Set apptOutApp = Nothing Set OutApp = Nothing Loop MsgBox "Termine an Outlook übertragen!" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

With apptOutApp '..... Set jedesJahr = neuerTermin.GetRecurrencePattern ' wiederkehrender Termin jedesJahr.RecurrenceType = olRecursYearly ' wiederkehrender Termin '.... End With

Sub Termin_nach_Outlook() Dim OutApp As Object, apptOutApp As Object 'Hier beginnen die Termine Range("B2").Select Do Until ActiveCell.Value = "" Set OutApp = CreateObject("Outlook.Application") Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem) With apptOutApp 'Datum und Uhrzeit .Start = Format(ActiveCell.Value, "dd.mm.yyyy") & " 08:00" 'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen 'Termininfo .Subject = "Geburtstag von: " & ActiveCell.Offset(0, -1).Value 'oder der Betreff steht in der Spalte rechts von den Terminen 'Zusätzlicher Text .Body = "" 'ort .Location = "geboren am:" & " " & ActiveCell.Offset(0, 0).Value .Duration = "5" 'Erinnerung .ReminderMinutesBeforeStart = 10 'mit Sound .ReminderPlaySound = True 'Erinnerung wiederholen Set jedesJahr = neuerTermin.GetRecurrencePattern ' wiederkehrender Termin jedesJahr.RecurrenceType = olRecursYearly ' wiederkehrender Termin .ReminderSet = True .Categories = "Geburtstage" 'Termin speichern .Save End With 'Nächste Zelle auswählen ActiveCell.Offset(1, 0).Select 'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal Set apptOutApp = Nothing Set OutApp = Nothing Loop MsgBox "Termine an Outlook übertragen!" End Sub

Dim OutApp As Object, apptOutApp As Object Dim OutPattern As RecurrencePattern 'Hier beginnen die Termine Range("B2").Select Do Until ActiveCell.Value = "" Set OutApp = CreateObject("Outlook.Application") Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem) With apptOutApp 'Datum und Uhrzeit .Start = Format(ActiveCell.Value, "dd.mm.yyyy") & " 08:00" 'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen 'Termininfo .Subject = "Geburtstag von: " & ActiveCell.Offset(0, -1).Value 'oder der Betreff steht in der Spalte rechts von den Terminen 'Zusätzlicher Text .Body = "" 'ort '######################## eingefügt ########################### Set OutPattern = apptOutApp.GetRecurrencePattern OutPattern.RecurrenceType = olRecursYearly '############################################################## .Location = "geboren am:" & " " & ActiveCell.Offset(0, 0).Value .Duration = "5" 'Erinnerung .ReminderMinutesBeforeStart = 10 'mit Sound .ReminderPlaySound = True 'Erinnerung wiederholen .ReminderSet = True .Categories = "Geburtstage" 'Termin speichern .Save End With 'Nächste Zelle auswählen ActiveCell.Offset(1, 0).Select 'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal Set apptOutApp = Nothing Set OutApp = Nothing Loop MsgBox "Termine an Outlook übertragen!" End Sub

Hallo Selma,
ich habe mich eben noch mal kurz an Dein Problem gewagt.

Option Explicit


Function AppointmentExists(ByVal objOutlook As Object, ByVal datStart As Date, ByVal strSubject As String) As Boolean
   Dim objMapiFolder As Object
   Dim objCalendarItem As Object
   AppointmentExists = True
   Set objMapiFolder = objOutlook.GetNamespace("MAPI").GetDefaultFolder(9)  ' 9 = olFolderCalendar 
   For Each objCalendarItem In objMapiFolder.Items
      If objCalendarItem.Subject = strSubject And _
         Month(objCalendarItem.Start) = Month(datStart) And _
         Day(objCalendarItem.Start) = Day(datStart) Then
         Exit Function
      End If
   Next objCalendarItem
   AppointmentExists = False
End Function


Private Sub Termin_nach_Outlook_Click()
Dim OutApp As Object, apptOutApp As Object
Dim OutPattern As RecurrencePattern
Dim objOutlook As Object
Dim objAppointmentItem As Object
   Dim datStart As Date
   Dim strSubject As String
   Dim lngZeile As Long
'Hier beginnen die Termine 
Range("B2").Select
lngZeile = 2
Do Until Cells(lngZeile, 1).Value = ""
    datStart = Cells(lngZeile, 2).Value & " 08:00:00"
    strSubject = "Geburtstag von: " & Cells(lngZeile, 1).Value

    Set OutApp = CreateObject("Outlook.Application")
    Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem) 
        If Not AppointmentExists(OutApp, datStart, strSubject) Then
        With apptOutApp
            'Datum und Uhrzeit 
            .Start = datStart
            'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen 
            'Termininfo 
            .Subject = strSubject
            'oder der Betreff steht in der Spalte rechts von den Terminen 
            'Zusätzlicher Text 
            .Body = ""
            'ort 
            '######################## eingefügt ########################### 
             Set OutPattern = apptOutApp.GetRecurrencePattern
             OutPattern.RecurrenceType = olRecursYearly
            '############################################################## 
            .Location = "geboren am:" & " " & datStart
            .Duration = "5"
            'Erinnerung 
            .ReminderMinutesBeforeStart = 10
            'mit Sound 
            .ReminderPlaySound = True
            'Erinnerung wiederholen 
            .ReminderSet = True
            .Categories = "Geburtstage"
            'Termin speichern 
            .Save
        End With
      End If
    'Nächste Zelle auswählen 
    'ActiveCell.Offset(1, 0).Select 
    lngZeile = lngZeile + 1
    'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal 
    Set apptOutApp = Nothing
    Set OutApp = Nothing
   Set objOutlook = Nothing
Loop
   'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal 
   MsgBox "Termine übertragen"
End 

Dieser VBA-Code prüft alle Outlook-Termine auf Subjekt (Bezeichnung) und Datum ohne Start, also Tag, Monat und Jahr.

Ich habe das deswegen so eingestellt, dass die Plausikontrolle unabhängig von der Uhrzeit ist.

Diese ist aber im Objekt: "objCalendarItem.Start" enthalten.

Daher die Extrahierung nach Tag, Monat und Jahr.

So werden die Daten nur einmalig übernommen.

hier die Datei:

https://www.herber.de/bbs/user/56819.xls


Alle anderen Anpassungen müsstest Du noch übernehmen.

Der VBA-Code ist nach Deinem Beispiel aufgebaut, also Spalte "A" = Subjekt (Bezeichnung, bzw. hier der Name) und in Spalte "B" das Datum.

Du könntest den Code erweitern, indem Du z.B. in Spalte "C" die Dauer eingibst etc. pp.

Gruß

Werner

Option Explicit Function AppointmentExists(ByVal objOutlook As Object, ByVal datStart As Date, ByVal strSubject As String) As Boolean Dim objMapiFolder As Object Dim objCalendarItem As Object AppointmentExists = True Set objMapiFolder = objOutlook.GetNamespace("MAPI").GetDefaultFolder(9) ' 9 = olFolderCalendar For Each objCalendarItem In objMapiFolder.Items If objCalendarItem.Subject = strSubject And _ Month(objCalendarItem.Start) = Month(datStart) And _ Day(objCalendarItem.Start) = Day(datStart) Then Exit Function End If Next objCalendarItem AppointmentExists = False End Function Private Sub Termin_nach_Outlook_Click() Dim OutApp As Object, apptOutApp As Object Dim OutPattern As RecurrencePattern Dim objOutlook As Object Dim objAppointmentItem As Object Dim datStart As Date Dim strSubject As String Dim lngZeile As Long 'Hier beginnen die Termine Range("B2").Select lngZeile = 2 Do Until Cells(lngZeile, 1).Value = "" datStart = Cells(lngZeile, 2).Value & " 08:00:00" strSubject = "Geburtstag von: " & Cells(lngZeile, 1).Value Set OutApp = CreateObject("Outlook.Application") Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem) If Not AppointmentExists(OutApp, datStart, strSubject) Then With apptOutApp 'Datum und Uhrzeit .Start = datStart 'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen 'Termininfo .Subject = strSubject 'oder der Betreff steht in der Spalte rechts von den Terminen 'Zusätzlicher Text .Body = "" 'ort '######################## eingefügt ########################### Set OutPattern = apptOutApp.GetRecurrencePattern OutPattern.RecurrenceType = olRecursYearly '############################################################## .Location = "geboren am:" & " " & datStart .Duration = "5" 'Erinnerung .ReminderMinutesBeforeStart = 10 'mit Sound .ReminderPlaySound = True 'Erinnerung wiederholen .ReminderSet = True .Categories = "Geburtstage" 'Termin speichern .Save End With End If 'Nächste Zelle auswählen 'ActiveCell.Offset(1, 0).Select lngZeile = lngZeile + 1 'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal Set apptOutApp = Nothing Set OutApp = Nothing Set objOutlook = Nothing Loop 'Variablen leeren,... sonst "kotzt" Outlook irgendwann mal MsgBox "Termine übertragen" End Dieser VBA-Code prüft alle Outlook-Termine auf Subjekt (Bezeichnung) und Datum ohne Start, also Tag, Monat und Jahr. Ich habe das deswegen so eingestellt, dass die Plausikontrolle unabhängig von der Uhrzeit ist. Diese ist aber im Objekt: "objCalendarItem.Start" enthalten. Daher die Extrahierung nach Tag, Monat und Jahr. So werden die Daten nur einmalig übernommen. hier die Datei: https://www.herber.de/bbs/user/56819.xls Alle anderen Anpassungen müsstest Du noch übernehmen. Der VBA-Code ist nach Deinem Beispiel aufgebaut, also Spalte "A" = Subjekt (Bezeichnung, bzw. hier der Name) und in Spalte "B" das Datum. Du könntest den Code erweitern, indem Du z.B. in Spalte "C" die Dauer eingibst etc. pp. Gruß Werner

Option Explicit Function OutTerminExist(ByVal OutApp As Object, ByVal datStart As Date, ByVal strSubject As String) As Boolean Dim OutMapiFolder As Object Dim OutCalendarItem As Object OutTerminExist = True Set OutMapiFolder = OutApp.GetNamespace("MAPI").GetDefaultFolder(9) ' 9 = olFolderCalendar For Each OutCalendarItem In OutMapiFolder.Items If OutCalendarItem.Subject = strSubject And _ Month(OutCalendarItem.Start) = Month(datStart) And _ Day(OutCalendarItem.Start) = Day(datStart) Then Exit Function End If Next OutCalendarItem OutTerminExist = False End Function Private Sub Termin_nach_Outlook_Click() Dim OutApp As Object Dim apptOutApp As Object Dim OutPattern As RecurrencePattern Dim datStart As Date Dim strSubject As String Dim lngZeile As Long lngZeile = 2 '1. Zeile der Geburtstagseinträge der Exceltabelle Do Until Cells(lngZeile, 1).Value = "" Set OutApp = CreateObject("Outlook.Application") Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem) datStart = Cells(lngZeile, 2).Value ' & " 08:00:00" strSubject = "Geburtstag von: " & Cells(lngZeile, 1).Value If Not OutTerminExist(OutApp, datStart, strSubject) Then With apptOutApp .Start = datStart 'Datum und Uhrzeit .AllDayEvent = True ' für ganztägig .Subject = strSubject .Body = "" Set OutPattern = apptOutApp.GetRecurrencePattern OutPattern.RecurrenceType = olRecursYearly ' wiederkehrender Termin .Location = "geboren am:" & " " & datStart .Duration = "5" .ReminderMinutesBeforeStart = 10 'Erinnerung .ReminderPlaySound = True 'mit Sound .ReminderSet = True 'Erinnerung wiederholen .Categories = "Geburtstage" .Save 'Termin speichern End With Cells(lngZeile, 3).Value = "eingetragen" Else: Cells(lngZeile, 3).Value = "vorhanden!" End If lngZeile = lngZeile + 1 'Variablen leeren Set apptOutApp = Nothing Set OutApp = Nothing Loop MsgBox "Termine übertragen" End Sub

Function OutTerminExist(ByVal OutApp As Object, ByVal datStart As Date, ByVal strSubject As _ String) As Boolean Dim OutMapiFolder As Object Dim OutCalendarItem As Object OutTerminExist = True Set OutMapiFolder = OutApp.GetNamespace("MAPI").GetDefaultFolder(9) ' 9 = olFolderCalendar _ For Each OutCalendarItem In OutMapiFolder.Items If OutCalendarItem.Subject = strSubject And _ Year(OutCalendarItem.Start) > 1900 And _ Month(OutCalendarItem.Start) = Month(datStart) And _ Day(OutCalendarItem.Start) = Day(datStart) Then Exit Function End If Next OutCalendarItem OutTerminExist = False End Function

Option Explicit Function OutTerminExist(ByVal OutApp As Object, ByVal datStart As Date, ByVal strSubject As String) As Boolean Dim OutMapiFolder As Object Dim OutCalendarItem As Object OutTerminExist = True Set OutMapiFolder = OutApp.GetNamespace("MAPI").GetDefaultFolder(9) ' 9 = olFolderCalendar For Each OutCalendarItem In OutMapiFolder.Items If OutCalendarItem.Subject = strSubject And _ Month(OutCalendarItem.Start) = Month(datStart) And _ Day(OutCalendarItem.Start) = Day(datStart) Then Exit Function End If Next OutCalendarItem OutTerminExist = False End Function Private Sub Termin_nach_Outlook_Click() Dim OutApp As Object Dim apptOutApp As Object Dim OutPattern As RecurrencePattern Dim datStart As Date Dim strSubject As String Dim lngZeile As Long Dim ohneJahr lngZeile = 2 '1. Zeile der Geburtstagseinträge der Exceltabelle ohneJahr = False Do Until Cells(lngZeile, 1).Value = "" Set OutApp = CreateObject("Outlook.Application") Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem) If Right(Cells(lngZeile, 2).Value, 1) = "." Then 'keine Jahresangabe datStart = Cells(lngZeile, 2).Value & "1900" ohneJahr = True Else: datStart = Cells(lngZeile, 2).Value ' & " 08:00:00" ohneJahr = False End If strSubject = "Geburtstag von: " & Cells(lngZeile, 1).Value If Not OutTerminExist(OutApp, datStart, strSubject) Then With apptOutApp .Start = datStart 'Datum und Uhrzeit .AllDayEvent = True ' für ganztägig .Subject = strSubject .Body = "" Set OutPattern = apptOutApp.GetRecurrencePattern OutPattern.RecurrenceType = olRecursYearly ' wiederkehrender Termin If ohneJahr Then .Location = Cells(lngZeile, 2).Value & " Jahr unbekannt!" Else: .Location = "geboren am:" & " " & datStart End If .Duration = "5" .ReminderMinutesBeforeStart = 10 'Erinnerung .ReminderPlaySound = True 'mit Sound .ReminderSet = True 'Erinnerung wiederholen .Categories = "Geburtstage" .Save 'Termin speichern End With Cells(lngZeile, 3).Value = "eingetragen" Else: Cells(lngZeile, 3).Value = "vorhanden!" End If lngZeile = lngZeile + 1 'Variablen leeren Set apptOutApp = Nothing Set OutApp = Nothing Loop MsgBox "Termine übertragen" End Sub

Beliebteste Forumthreads (12 Monate)

Termine aus Excel in Outlook übertragen ?

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Termine aus Excel in Outlook übertragen ?

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread