使用VBA快速统计词组（单词组合）词频

实例需求：产品清单如A列所示，现在如下统计词组词频。想必各位小伙伴都指定如何使用字典对象实现去重，进而实现单个单词的词频统计。

但是统计词组词频就没有那么简单了，为了便于演示，此处的词组只限于两个单词的组合。提到词组，很多时候大家先想到的是如何将获取全部的组合，例如n个无重复单词，可以产生的无重复词组个数为C(n,2) ，但是在本示例中并不需要获取这些全部组合，实现思路自然也就不同了。

在这里插入图片描述

示例代码如下。

Sub CountWorPair()
    Dim oDic1 As Object, oDic2 As Object, oDic3 As Object
    Dim aProd, vProd, aWord, vWord, vKey, arrData
    Dim sKey1 As String, sKey2 As String
    Dim i As Long, j As Long, k As Long
    Set oDic1 = CreateObject("scripting.dictionary")
    Set oDic2 = CreateObject("scripting.dictionary")
    Set oDic3 = CreateObject("scripting.dictionary")
    arrData = Range("A1").CurrentRegion.Value
    For i = LBound(arrData) + 1 To UBound(arrData)
        aWord = Split(arrData(i, 1))
        For Each vWord In aWord
            If oDic1.exists(vWord) Then
                oDic1(vWord) = oDic1(vWord) & "," & arrData(i, 1)
            Else
                oDic1(vWord) = arrData(i, 1)
            End If
        Next
    Next i
    For Each vKey In oDic1.keys
        aProd = Split(oDic1(vKey), ",")
        oDic2.RemoveAll
        For Each vProd In aProd
            aWord = Split(vProd)
            For Each vWord In aWord
                If oDic2.exists(vWord) Then
                    oDic2(vWord) = oDic2(vWord) + 1
                Else
                    oDic2(vWord) = 1
                End If
            Next
        Next
        For Each vWord In oDic2.keys
            If vWord <> vKey Then
                sKey1 = vKey & " " & vWord
                sKey2 = vWord & " " & vKey
                If oDic3.exists(sKey1) Then
                    If oDic2(vWord) > oDic3(sKey1) Then oDic3(sKey1) = oDic2(vWord)
                ElseIf oDic3.exists(sKey2) Then
                    If oDic2(vWord) > oDic3(sKey2) Then oDic3(sKey2) = oDic2(vWord)
                Else
                    oDic3(sKey1) = oDic2(vWord)
                End If
            End If
        Next
    Next
    Range("D:E").Clear
    Range("D1:E1").Value = Array("Word Pair", "Times")
    Range("D2").Resize(oDic3.Count, 1) = Application.Transpose(oDic3.keys)
    Range("E2").Resize(oDic3.Count, 1) = Application.Transpose(oDic3.items)
End Sub

【代码解析】
第6~7行代码创建字典对象。

oDic1用于按照单词合并产品名称，即字典键为单词，字典值为逗号连接的产品名称。
oDic2用于统计每个单词的出现次数，注意并非全部产品的词频。
oDic3用于统计词组（两个单词组合）的词频。
第9行代码将数据表加载到数组中。
第10~19行代码循环处理每行数据，按照单词合并产品名称，oDic1("Red")的值为所有包含Red的产品名称。
第14行代码合并产品名称。
第16行代码为字典对象添加键值。
第20~42行代码循环遍历oDic1中的键，最终实现统计词组词频。
第21行代码读取oDic1的值（逗号连接的产品名称），并按照逗号拆分为产品列表（数组）。
第22行代码清空oDic2对象。
第23~32行代码循环变量产品列表aProd。
第24行代码将产品列表拆分为单词列表aWord。
第25~31行代码统计单词词频。例如处理oDic1("Red")时，将统计包含Red的产品名称中，每个单词出现的次数。
第33~41行代码循环遍历oDic2中的键，统计词组词频。
第34行代码判断oDic1键是否与oDic2键相同，由于产品名称中不会出现重复的单词，因此Red Red属于无效的词组。
第35~36行代码将两个键值按照不同的次序进行组合。
这里是本示例中的小技巧，由于Red Car和Car Red实际上属于同一个词组，二者的词频也移动相同，因此在输出结果中只需要保留一个即可，所以此处需要将创建两个变量sKey1和sKey2。
第37行代码判断oDic3中是否已经存在sKey1和sKey2，如果不存在，那么第38行代码在oDic3中添加键值。

这个逻辑看起来有些复杂，下面举例说明。
以词组Red Car为例，oDic1("Red")的值为Red Car,Red Kia Car，经过拆分统计oDic2("Car")的值为2，即词频为2，最终oDic3("Red Car")的值2，当然结果字典中也可能是oDic3("Car Red")。

第43行代码清空目标单元格区域。
第44行代码设置表格标题。
第45行代码将词组（oDic3的键）写入D列。
第45行代码将词频（oDic3的值）写入E列。

微软文档: