程序如下圖：
代碼文本：
Option Explicit
Sub 宏1()
Dim arr, db, i, k
Set db = CreateObject("Scripting.Dictionary")
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
k = Trim(arr(i, 3))
If k <> "" Then
If Not db.Exists(k) Then
db.Add k, CreateObject("Scripting.Dictionary")
db(k).Add "分子", CreateObject("Scripting.Dictionary")
db(k).Add "分母", CreateObject("Scripting.Dictionary")
End If
db(k)("分子")(arr(i, 1)) = True
db(k)("分母")(arr(i, 2)) = True
End If
Next i
ReDim arr(1 To db.Count + 1, 1 To 4)
arr(1, 2) = "分子"
arr(1, 3) = "分母"
arr(1, 4) = "率"
i = 2
For Each k In db.Keys
arr(i, 1) = k
arr(i, 2) = db(k)("分子").Count
arr(i, 3) = db(k)("分母").Count
arr(i, 4) = arr(i, 2) / arr(i, 3)
i = i + 1
Next k
Range("e1").Resize(UBound(arr), 4) = arr
End Sub