Sub FontReplaceTimesNewRoman()
'
' FontReplaceTimesNewRoman Macro
'
'
Dim objWordApp As Word.Application
Dim objWordDoc As Word.Document
Dim objSelection As Selection
Dim FileString As String
Const wdReplaceAll = 2

    Set objWordApp = CreateObject("Word.Application")
    FileString = "C:\Downloads\VerificationProcedures.docx"

    objWordApp.Documents.Open (FileString)
    objWordApp.Visible = True

    Set objWordDoc = objWordApp.ActiveDocument
    Set objSelection = objWordApp.Selection

    objSelection.Find.Font.Name = "Times New Roman"
    objSelection.Find.Forward = True
    objSelection.Find.Replacement.Font.Name = "Calibri"
    objSelection.Find.Execute "", , False, , , , , , , , wdReplaceAll

    objWordApp.Documents.Close (Word.WdSaveOptions.wdSaveChanges)
    objWordApp.Quit
    Set objWordApp = Nothing
End Sub