Macro to Find & Replace in Subject of Outlook Appointment

This isn't a question, but an answer.  I have been trying to find a way to perform a search/replace in the subject lines of Outlook calendar appointments.  For some reason, when I imported into a new Exchange account, Exchange inserted the word"Copy: " at the beginning of many of my appointments, and I wanted to get rid of those insertions.  I couldn't find any good VBA to get the job done, so I wrote my own.  This macro will ask the user for the "find" string, the "replace" string and the calendar folder that will be the subject of the search/replace.  It will then perform the replacement and provide the number of changed items.  Hope it is helpful to others.  Probably could be made to work on other types of folders as well with a little tweaking. 

Sub ApptFindReplace()
' This macro will find/replace specified text in the subject line of all appointments in a specified calendar

    Dim olApp As Outlook.Application
    Dim CalFolder As Outlook.MAPIFolder
    Dim Appt As Outlook.AppointmentItem
    Dim OldText As String
    Dim NewText As String
    Dim CalChangedCount As Integer
    
    ' Set Outlook as active application
    Set olApp = Outlook.Application
    
    ' Get user inputs for find text, replace text and calendar folder
    MsgBox ("This script will perform a find/replace in the subject line of all appointments in a specified calendar.")
    OldText = InputBox("What is the text string that you would like to replace?")
    NewText = InputBox("With what would you like to replace it?")
    MsgBox ("In the following dialog box, please select the calendar you would like to use.")
    Set CalFolder = Application.Session.PickFolder
    On Error GoTo ErrHandler:
    ' Check to be sure a Calendar folder was selected
    Do
    If CalFolder.DefaultItemType <> olAppointmentItem Then
        MsgBox ("This macro only works on calendar folders.  Please select a calendar folder from the following list.")
        Set CalFolder = Application.Session.PickFolder
        On Error GoTo ErrHandler:
    End If
    Loop Until CalFolder.DefaultItemType = olAppointmentItem
    ' Loop through appointments in calendar, change text where necessary, keep count
    CalChangedCount = 0
    For Each Appt In CalFolder.Items
        If InStr(Appt.Subject, OldText) <> 0 Then
            Debug.Print "Changed: " & Appt.Subject & " - " & Appt.Start
            Appt.Subject = Replace(Appt.Subject, OldText, NewText)
            Appt.Save
       CalChangedCount = CalChangedCount + 1
       End If
    Next
    ' Display results and clear table
    MsgBox (CalChangedCount & " appointments had text in their subjects changed from '" & OldText & "' to '" & NewText & "'.")
    Set Appt = Nothing
    Set CalFolder = Nothing
    Exit Sub
ErrHandler:
    MsgBox ("Macro terminated.")
    Exit Sub

End Sub