Ik heb de gehele topic doorgenomen om je code aan te passen naar je wensen.
Code:Sub SetAppt() Dim olApp As New Outlook.Application Dim olApt As AppointmentItem Dim Ddatum As Date Dim sFind As String Dim ns As Outlook.Namespace Dim olFolder As Outlook.MAPIFolder Dim Appt As Outlook.AppointmentItem Dim lRij As Long Set ns = olApp.GetNamespace("MAPI") lRij = 2 While ActiveSheet.Range("B" & lRij) <> "" sFind = "[Start] = '" & Format(ActiveSheet.Range("E" & lRij), "ddddd h:mm") & "' AND [Subject]='" & ActiveSheet.Range("B" & lRij) & "'" Set olFolder = ns.GetDefaultFolder(olFolderCalendar) Set Appt = olFolder.Items.Find(sFind) If ActiveSheet.Range("E" & lRij) < Date Then BerichtDatum = MsgBox("De datum ligt in het verleden." & Chr(13) & "Wil je een herinnering plaatsen?", vbInformation + vbYesNo, "Datum in verleden.") If BerichtDatum = vbYes Then If Not Appt Is Nothing Then Wijzigen = MsgBox("wilt u de afspraak wijzigen?", vbYesNo + vbExclamation, "Afspraak wijzigen.") End If Set olApp = New Outlook.Application Set olApt = olApp.CreateItem(olAppointmentItem) If Appt Is Nothing Then Set Appt = olFolder.Items.Add With Appt .Start = ActiveSheet.Range("E" & lRij) .End = .Start + TimeValue("00:30:00") .Subject = ActiveSheet.Range("B" & lRij) .Location = ActiveSheet.Range("C" & lRij) .Body = "Vandaag " & ActiveSheet.Range("B" & lRij) & " bespreken met de opdrachtgever" .MeetingStatus = olMeeting .Save End With End If End If lRij = lRij + 1 Wend Set olApt = Nothing Set olApp = Nothing End Sub
De macro controleert vanaf rij 2 in kolom B of er iets is ingevuld.
Vervolgens wordt gekeken naar de datum in de E-kolom.
Is die datum in het verleden dan verschijnt een melding voor een afspraak.
Bestaat die afspraak al dan verschijnt de vraag of je deze wilt wijzigen.
De afspraak wordt gemaakt danwel aangepast.
Dat wat het globaal wel.
Met vriendelijke groet,
Roncancio
Roncancio,
Deze oplossing werkt. Hartelijk dank voor al je inspanning. :thumb:
Groeten Harry