Sub FlagAlpaNumericWords()
Dim oRng As Range, oNum As Range
Dim bCompound As Boolean
Dim lngStart As Long
  Set oRng = ActiveDocument.Range
  With oRng.Find
    Do While .Execute(findText:="[0-9]{1,}", MatchWildcards:=True)
      bCompound = False
      Set oNum = oRng.Words(1)
      lngStart = oNum.Start
      Do While oRng.Characters.First.Previous = "-"
        oRng.MoveStart wdCharacter, -1
        oRng.MoveStart wdWord, -1
        oNum.Start = oRng.Start
        bCompound = True
      Loop
      Do While oRng.Characters.Last.Next = "-"
        oRng.MoveEnd wdCharacter, 1
        oRng.MoveEnd wdWord, 1
        bCompound = True
      Loop
      If bCompound Then
        Set oNum = oRng
        If oNum.Start > lngStart Then oNum.Start = lngStart
        oNum.Select
      Else
        oNum.End = oNum.End - 1
      End If
      If TestRegExp("[A-Z]", oNum.Text) = True Then
        oNum.HighlightColorIndex = wdYellow
      End If
      oRng.Collapse 0
    Loop
  End With
End Sub

Function TestRegExp(strFind As String, strText As String) As Boolean
Dim objRegExp As Object
  Set objRegExp = CreateObject("VBScript.RegExp")
  objRegExp.Pattern = strFind
  objRegExp.IgnoreCase = True
  objRegExp.Global = True
  TestRegExp = objRegExp.Test(strText)
  Set objRegExp = Nothing
End Function