Find and Replace VB Macro - vba

Question

I am using a Find and Replace script/macro in MS Word. For the two lines below, how would I adjust this to be case sensitive? Right now it will replace us, bus, ect..
Const strFind As String = "US"
Const strRepl As String = "USA"
Sub BatchProcess()
Dim strFileName As String
Dim strPath As String
Dim oDoc As Document
Dim fDialog As FileDialog
Dim oStory As Range
Dim oRng As Range
Const strFind As String = "2017"
Const strRepl As String = "2018"
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , _
"List Folder Contents"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1) & "\"
End With
strFileName = Dir$(strPath & "*.docx")
While Len(strFileName) <> 0
WordBasic.DisableAutoMacros 1
Set oDoc = Documents.Open(strPath & strFileName)
For Each oStory In ActiveDocument.StoryRanges
Set oRng = oStory
With oRng.Find
Do While .Execute(FindText:=strFind)
oRng.Text = strRepl
oRng.Collapse wdCollapseEnd
Loop
End With
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
Set oRng = oStory
With oRng.Find
Do While .Execute(FindText:=strFind)
oRng.Text = strRepl
oRng.Collapse wdCollapseEnd
Loop
End With
Wend
End If
Next oStory
oDoc.SaveAs FileName:=strPath & strFileName
oDoc.Close SaveChanges:=wdDoNotSaveChanges
strFileName = Dir$()
WordBasic.DisableAutoMacros 0
Wend
Set oDoc = Nothing
Set oStory = Nothing
Set oRng = Nothing
End Sub
In response to the post below. I have added the entire code.

Answer 1

The Find and Replace method has a boolean MatchCase property. Set it to True.
Example: In your DoWhile code. Do While .Execute(FindText:=strFind, MatchCase:=True)

Answer 2

Simply matching the case is insufficient if what you're searching for as a whole word might also exist within a larger string. Try:
Sub BatchProcess()
Application.ScreenUpdating = False
Dim strFileName As String, strPath As String
Dim oDoc As Document, oStory As Range
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1) & "\"
End With
strFileName = Dir$(strPath & "*.docx")
WordBasic.DisableAutoMacros 1
While Len(strFileName) <> 0
Set oDoc = Documents.Open(strPath & strFileName)
With oDoc
For Each oStory In .StoryRanges
While Not (oStory Is Nothing)
oStory.Find.Execute FindText:="<US>", Replacewith:="USA", Forward:=True, _
Wrap:=wdFindContinue, MatchWildcards:=True, Replace:=wdReplaceAll
Set oStory = oStory.NextStoryRange
Wend
Next oStory
.SaveAs FileName:=strPath & strFileName
.Close SaveChanges:=wdDoNotSaveChanges
End With
strFileName = Dir$()
Wend
WordBasic.DisableAutoMacros 0
Set oDoc = Nothing: Set oStory = Nothing
Application.ScreenUpdating = True
End Sub
Note that I've used wildcards, combined with as the Find expression. That guarantees only whole upper-case words will be matched. you could achieve the same with:
oStory.Find.Execute FindText:="US", Replacewith:="USA", Forward:=True, _
Wrap:=wdFindContinue, MatchWholeWord:=True, MatchCase:=True, Replace:=wdReplaceAll
Note, too, the overall simplification of your code.