Sub BatchReplaceFont()
  Dim objDoc As Document
  Dim objSingleWord As Range
  Dim strFile As String, strFolder As String
 
  strFolder = "C:\Users\Test\Desktop\test files\"
  strFile = Dir(strFolder & "*.docx", vbNormal)
 
  While strFile <> ""
  Set objDoc = Documents.Open(FileName:=strFolder & strFile)
 
  For Each objSingleWord In objDoc.Words
    If objSingleWord.Font.Name = "Arial" Then
      objSingleWord.Font.Name = "Calibri"
    End If
  Next objSingleWord
 
  objDoc.Save
  objDoc.Close
  strFile = Dir()
  Wend
End Sub