Doppelte Termine in Outlook

Forumthread: Doppelte Termine in Outlook

01.06.2017 12:39:45

Kurt

Hi,
eine Frage hätte ich noch zu meinem Code. Es funktioniert soweit alles nur wenn ich das Makro mehrmals ablaufen lasse trägt es mir die Termine immer wieder ein, sodass ich irgendwann den selben Termin 5 mal drin stehen hätte. Ich bräuchte quasi eine Möglichkeit das entweder nur dass was neu eingetragen wurde übernommen wird, oder das die Termine die schon drin stehen einfach ersetzt werden. Kann mir da vllt jemand weiterhelfen?
Mein Code:


Private Sub CommandButton1_Click()
Dim objOutlook As Outlook.Application
Dim apptOutlook As Outlook.AppointmentItem
'Auswahl der ersten Zelle des Kalenders
Range("C5").Select
'Schleife für die Auswahl der nächsten Spalte
Do Until ActiveCell.Value = "Ende"
'Schleife für die Auswahl der nächsten Zeile
Do Until ActiveCell.Value = "Ende"
'Zellen ohne Inhalt werden rausgelassen
If ActiveCell.Value  "" Then
'Festlegung der Variabelen
Set objOutlook = CreateObject("Outlook.Application")
Set apptOutlook = objOutlook.CreateItem(olAppointmentItem)
'Übertragung des Termins in Outlook
With apptOutlook
'Titel des Termins
.Subject = ActiveCell.Value
'Datum des Termins
.Start = Format(Cells(ActiveCell.Row, 1).Value, "dd.mm.yyyy") & " 08:00"
'Inhalt des Termins
.Body = ActiveCell.Comment.Text
'Ort des Termins
.Location = Cells(4, ActiveCell.Column).Value
'Dauer des Termins
.Duration = 60
'Errinerungen an Termin
.ReminderMinutesBeforeStart = 1440
.ReminderPlaySound = True
.ReminderSet = True
'Speichern des Termins
.Save
End With
End If
'Zeilensprung nach unten
ActiveCell.Offset(1, 0).Select
'Löschen der Variablenzuordnung, da Outlook sonst Faxen macht
Set apptOutlook = Nothing
Set objOutlook = Nothing
Loop
'Auswahl der ersten Zelle der Tabelle in der nächsten Spalte
ActiveCell.Offset(0, 1).Select
Cells(5, ActiveCell.Column).Select
Loop
'Nachrichtfenster mit: siehe Klammer
MsgBox ("Termine in Outlook übertragen")
End Sub

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

so...

02.06.2017 14:52:55

Max2
ArrayList variante

02.06.2017 15:32:23

Max2
AW: so...

06.06.2017 07:46:03

Kurt

so...

02.06.2017 14:52:55

Max2

Hallo,
so kann man es machen ohne den code um zu schreiben..
ich würde das ganze an deiner stelle in eine Arraylist schreiben,
dann prüfen ob termin vorhanden, falls ja, dann aus ArrayList löschen
und anschließend alles aus der ArrayList hinzufügen.

Private Sub CommandButton1_Click()
Dim objOutlook As Outlook.Application
Dim apptOutlook As Outlook.AppointmentItem
Dim oTermin As Object
Dim oAlleTermine As Object
'Auswahl der ersten Zelle des Kalenders
Range("C5").Select
On Error Resume Next
'Schleife für die Auswahl der nächsten Spalte
Do Until ActiveCell.Value = "Ende"
'Schleife für die Auswahl der nächsten Zeile
Do Until ActiveCell.Value = "Ende"
'Zellen ohne Inhalt werden rausgelassen
If ActiveCell.Value  "" Then
'Festlegung der Variabelen
Set objOutlook = CreateObject("Outlook.Application")
Set apptOutlook = objOutlook.CreateItem(olAppointmentItem)
Set oAlleTermine = objOutlook. _
GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
'Übertragung des Termins in Outlook
With apptOutlook
        For Each oTermin In oAlleTermine.Items
If oTermin.Subject = ActiveCell.Value Then GoTo neuerTermin
Next oTermin
'Titel des Termins
.Subject = ActiveCell.Value
'Datum des Termins
.Start = Format(Cells(ActiveCell.Row, 1).Value, "dd.mm.yyyy") & " 08:00"
'Inhalt des Termins
.Body = ActiveCell.Comment.Text
'Ort des Termins
.Location = Cells(4, ActiveCell.Column).Value
'Dauer des Termins
.Duration = 60
'Errinerungen an Termin
.ReminderMinutesBeforeStart = 1440
.ReminderPlaySound = True
.ReminderSet = True
'Speichern des Termins
.Save
End With
End If
neuerTermin:
'Zeilensprung nach unten
ActiveCell.Offset(1, 0).Select
'Löschen der Variablenzuordnung, da Outlook sonst Faxen macht
Set apptOutlook = Nothing
Set objOutlook = Nothing
Loop
'Auswahl der ersten Zelle der Tabelle in der nächsten Spalte
ActiveCell.Offset(0, 1).Select
Cells(5, ActiveCell.Column).Select
Loop
'Nachrichtfenster mit: siehe Klammer
MsgBox ("Termine in Outlook übertragen")
End Sub

ArrayList variante

02.06.2017 15:32:23

Max2

Hallo,
hier eine nicht getestete Variante mit ArrayList:


Option Explicit
Private mySubj As New ArrayList
Private myStart As New ArrayList
Private myBody As New ArrayList
Private myLoca As New ArrayList
Sub deinButtonSub()
create_List
delete_items_and_add_content
End Sub
Private Sub create_List()
Dim i As Long, j As Long
Dim lRow As Long, lCol As Long
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(1)
With ws
i = 5
j = 3
lCol = .Cells(5, .Columns.Count).End(xlToLeft).Column
Do
lRow = .Cells(.Rows.Count, j).End(xlUp).Row
Do Until .Cells(i, j).Value = "Ende" Or i > lRow
Debug.Print .Cells(i, j).Value
mySubj.Add .Cells(i, j).Value
myStart.Add .Cells(i, 1).Value
myBody.Add .Cells(i, j).Comment.Text
myLoca.Add .Cells(4, j).Value
i = i + 1
Loop
i = 5
j = j + 1
Loop Until j > lCol
End With
End Sub
Private Sub delete_items_and_add_content()
Dim oOut As Outlook.Application
Dim oAppointments As Outlook.AppointmentItem
Dim oTermin As Object
Dim oAlleTermine As Object
Dim i As Long
On Error Resume Next
Set oOut = CreateObject("Outlook.Application")
Set oAlleTermine = oOut. _
GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
Do Until i > mySubj.Count - 1
For Each oTermin In oAlleTermine.Items
If oTermin.Subject = mySubj(i) Then
mySubj.RemoveAt (i)
myStart.RemoveAt (i)
myBody.RemoveAt (i)
myLoca.RemoveAt (i)
End If
Next oTermin
i = i + 1
Loop
For i = 0 To mySubj.Count - 1
Set oAppointments = oOut.CreateItem(olAppointmentItem)
With oAppointments
.Subject = mySubj(i)
.Start = Format(myStart(i), "dd.mm.yyyy") & " 08:00"
.Body = myBody(i)
.Location = myLoca(i)
.Duration = 60
.ReminderMinutesBeforeStart = 1440
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
Set oAppointments = Nothing
Next i
End Sub

AW: so...

06.06.2017 07:46:03

Kurt

Danke
funktioniert besser als das was ich mir da zusammen gebastelt habe

Beliebteste Forumthreads (12 Monate)

Forumthread: Doppelte Termine in Outlook

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread