Terminliste mit Serienmuster
12.03.2020 10:06:29
Patrick
habe noch mal ein Anliegen, bei dem ich Hilfe benötige. Das Makro an sich habe ich übernommen, funktioniert auch fast einwandfrei, aber irgendwie hat sich nun auch wieder ein Laufzeitfehler eingeschlichen und ich bekomme diesen einfach nicht weg -.-
Hier startet mein Fehler ( .Start = Format(Wsh.Cells(Zeile, "J").Value, "dd.mm.yyyy") & " 08:00")
Außerdem habe ich mir vorgestellt, das die Termine/ Geburtstage mit jährlichen Serienmuster eingestellt werden. Wenn z.B. ein Geburtstag auf den 04.05. fällt, dass er dann auch im nächsten Jahr wieder am 04.05. erscheint.
Habe schon so einiges ausprobiert mit übernommenen Makro/VBA aus dem Netz, selber noch dran rumgebastelt, aber komme einfach nicht zum Endergebnis.
Wäre Super, wenn mir ein paar Spezis mal einen Tipp oder mein Makro richtig stellen könnten.
Gruß
Patrick =)
Hier mal mein genutzter Makro:
Sub Excel_Control_Termine_nach_Outlook()
Dim objOL As Object, objKal As Object
Dim Wsh As Worksheet
'Hier beginnen die Termine
Dim Zeile As Long, iAnzMAil As Integer
Dim bIsMail As Boolean
bIsMail = True 'Mail oder Kalendereintrag
Set objOL = CreateObject("Outlook.Application")
Set Wsh = ThisWorkbook.Sheets("Geburtstagsliste")
For Zeile = 2 To Wsh.UsedRange.Rows.Count
If Wsh.Cells(Zeile, 10) > 0 Then 'Datum vorhanden?
If IsEmpty(Wsh.Cells(Zeile, "L").Value) Then 'Status ohne Wert
If bIsMail Then
'Kalendereintrag
Set objKal = objOL.CreateItem(1) 'olAppointmentItem
With objKal
'Datum wird die Termine aus der Zelle genommen
.Start = Format(Wsh.Cells(Zeile, "J").Value, "dd.mm.yyyy") & " 08:00"
'Termininfo
.Subject = "Geburtstag: " & Wsh.Cells(Zeile, "C").Value
'Zusätzlicher Text
Nachricht = Wsh.Cells(Zeile, "H") & vbLf
'Nachricht = Nachricht & "weiterer Text möglich"
.Body = Nachricht
'Anzeige
.display
'ort
.Location = "Geburtstag " & Wsh.Cells(Zeile, "C").Value
'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen
.Duration = "5"
.ReminderMinutesBeforeStart = "20" 'Erinnerung
.ReminderPlaySound = True 'mit Sound :-)
.ReminderSet = True 'Erinnerung wiederholen
.Importance = olImportanceHigh 'Wichtigkeit
.MeetingStatus = olMeeting 'Status
Application.DisplayAlerts = False
.Save 'Termin speichern
'Schließen ohne senden
'Application.SendKeys "%DL"
Application.SendKeys "%S" '*** automatisch ohne überprüfung senden ***
Application.DisplayAlerts = True
'Erledigt setzen
Wsh.Cells(Zeile, "L").Value = "in Outlook übernommen"
End With
Set objKal = Nothing
End If
End If
End If
Next Zeile
Set objOL = Nothing
'MsgBox "Termine an Outlook übertragen!"
End Sub