'无法判断是否为词组,需要规则,,,
Option Explicit
Sub test()
Dim arr, dic, i, j, t, txt As String, cnt, mark
Set dic = CreateObject("scripting.dictionary")
mark = Split(", . ; : ?") '标点符号,可添加,中间用单空格隔开
txt = "a b c s A c C d c c d f w " '单词,中间空格隔开,空格数不限
For i = 0 To UBound(mark)
txt = Replace(txt, mark(i), Space(1))
Next
arr = Split(LCase(txt)) '小写匹配
For i = 0 To UBound(arr)
If Len(arr(i)) Then dic(arr(i)) = dic(arr(i)) + 1: cnt = cnt + 1
Next
arr = Application.Transpose(Array(dic.keys, dic.items, dic.items))
For i = 1 To UBound(arr, 1) - 1
For j = i + 1 To UBound(arr, 1)
If arr(i, 2) < arr(j, 2) Then
t = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = t
t = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = t
End If
Next
arr(i, 3) = Round(arr(i, 2) / cnt, 4)
Next
arr(i, 3) = Round(arr(i, 2) / cnt, 4)
[c:c].NumberFormatLocal = "0.00%"
With [a:c]
.ClearContents
.Resize(UBound(arr, 1), 3) = arr
End With
End Sub |