Sub Acronyms()
    Dim dict, k, tmp
    Dim regExp, Match, Matches
    Dim rngRange As Range
    Set regEX = New regExp
    Set dict = CreateObject("scripting.dictionary")
    regEX.Pattern = "[A-Z]{2,}" '2 or more upper-case letters
    regEX.IgnoreCase = False
    regEX.Global = True
    Set Matches = regEX.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