Sub Acronyms()
Dim dict, k, tmp
Dim regExp, Match, Matches
Dim rngRange As Range
    Set regExp = CreateObject("vbscript.regexp")
    Set dict = CreateObject("scripting.dictionary")
    regExp.Pattern = "[A-Z]{2,}"    '2 or more upper-case letters
    regExp.IgnoreCase = False
    regExp.Global = True
    Set Matches = regExp.Execute(ActiveDocument.Range.Text)
    For Each Match In Matches
        tmp = Match.value
        If Not dict.Exists(tmp) Then dict.Add tmp, 0
        dict(tmp) = dict(tmp) + 1
    Next
    For Each k In dict.Keys
Debug.Print k, dict(k)
    Next k
End Sub