Sub Demo()
Dim StrRep As String, StrLeft As String, StrRight As String, i As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = InputBox("What is the text to Find")
    .Replacement.Text = ""
    StrRep = InputBox("What is the Replace text")
    StrLeft = Left(StrRep, 1)
    StrRight = Right(StrRep, Len(StrRep) - 1)
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  Do While .Find.Found
    i = i + 1
    With .Duplicate
      If .Words.First = .Sentences(1).Words.First Then
        .Text = UCase(StrLeft) & StrRight
      Else
        .Text = StrLeft & StrRight
      End If
    End With
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
MsgBox i & " instances replaced."
End Sub