Search within a column and repeat the search until all items are found

Thanks much for all of your effort. I have managed to get the find function working with a Do Loop. It moves sucessfully from "Today" to "Today" but when it gets to the last "Today" the macro freezes and won't fully complete the macro. I don't have the ability to attach the spreadsheet.

Here's my current macro

Sub FREEZEDATE()
'
' FREEZES DATES ON SUMMARY PAGE'

'
Sheets("SUMMARY").Select
ActiveSheet.Unprotect
Application.ScreenUpdating = False
Application.Goto Reference:="TOP"

Do
   
   Cells.Find(What:="TODAY", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -1).Activate
    'Freezing of date will occur here
    ActiveCell.Offset(0, 1).Activate
    Selection.ClearContents
    ActiveCell.Activate
    If Not Selection.Value = "" Then Exit Do
     
      Range("A6").Select
      ActiveSheet.Protect

End Sub