Can VB Abbreviate Words Correctly?

[leokuz]

I am having this MS Word macro which works well, but not fine. It replaces word Street to St which is the way I want, but it changes STREET TO ST (I need St), etc. However, I need them changed as follows:

Street or STREET to St
Avenue or AVENUE to Ave
Terrace or TERRACE to Ter
Circle or CIRCLE to Cir
Lane or LANE to Ln
Place or PLACE to Pl
Road or ROAD to Rd
Drive or DRIVE to Dr
Southwest or SOUTHWEST to SW
North or NORTH to N
South or SOUTH to S
Southeast or SOUTHEAST to SE
Northeast or NORTHEAST to NE

Here is the script

Sub ChangeWord()

  Dim rngStory As Word.Range

  Dim ReplWord As Long

  ReplWord = ActiveDocument.Sections(1).Headers(1).Range.StoryType

  For Each rngStory In ActiveDocument.StoryRanges

    Do

      With rngStory.Find

        .Text = "Street"

        .Replacement.Text = "St"

        .Wrap = wdFindContinue

        .Execute Replace:=wdReplaceAll

      End With
      
            With rngStory.Find

        .Text = "Avenue"

        .Replacement.Text = "Ave"

        .Wrap = wdFindContinue

        .Execute Replace:=wdReplaceAll

      End With

      Set rngStory = rngStory.NextStoryRange

    Loop Until rngStory Is Nothing

  Next

End Sub

I hope someone will find time to help me with my little project here