Sub Acronyms()
Dim dict, k, tmp
Dim regExp, Match, Matches
Dim oDoc As Document
    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
    Set oDoc = Documents.Add
    For Each k In dict.Keys
        'Debug.Print k, dict(k)
        oDoc.Range.InsertAfter k & ", " & dict(k) & vbCr
    Next k
    oDoc.Range.Paragraphs.Last.Range.Delete
    oDoc.Range.Sort
End Sub