Outlook 2013 - Suchen und Ersetzen ab bestimmten Datum

Sub FindReplaceAppointment()
    Dim oApp As Outlook.Application
    Dim oCalFolder As Outlook.MAPIFolder
    Dim oAppt As Outlook.AppointmentItem
    Dim sOldText As String
    Dim sNewText As String
    Dim iCalChangedCount As Integer
    Set oApp = Outlook.Application
    MsgBox ("This script will perform a find/replace in the subject line of all appointments in a specified calendar.")  
    sOldText = InputBox("What is the text string that you would like to replace?")  
    sNewText = InputBox("With what would you like to replace it?")  
    ' Check to be sure a Calendar folder was selected  
    Do
    If Not (oCalFolder Is Nothing) Then
        If (oCalFolder.DefaultItemType = olAppointmentItem) Then Exit Do
    End If
    MsgBox ("Please select a calendar folder from the following list.")  
    Set oCalFolder = Application.Session.PickFolder
    On Error GoTo ErrHandler:
Loop Until oCalFolder.DefaultItemType = olAppointmentItem
' Loop through appointments in calendar, change text where necessary, keep count  
iCalChangedCount = 0
For Each oAppt In oCalFolder.Items
    If InStr(oAppt.Subject, sOldText) <> 0 Then
        Debug.Print "Changed: " & oAppt.Subject & " - " & oAppt.Start  
        oAppt.Subject    = Replace(oAppt.Subject, sOldText, sNewText)
        oAppt.Save
        iCalChangedCount = iCalChangedCount + 1
    End If
Next
' Display results and clear table  
MsgBox (iCalChangedCount & " appointments had text in their subjects changed from '" & sOldText & "' to '" & sNewText & "'.")  
Set oAppt = Nothing
Set oCalFolder = Nothing
Exit Sub
    ErrHandler:
    MsgBox ("Macro terminated.")  
End Sub