使用VBA快速统计词组词频(多单词组合)（2/2）

实例需求：产品清单如A列所示，现在如下统计多单词组合词组词频。

在上一篇博客中《使用VBA快速统计词组词频(多单词组合)（1/2）》讲解了如何实现双词的词频统计。

本文将讲解如何实现3词的词频统计，掌握实现方法之后，可以很容易地将代码扩展到实现更多单词词频统计，实现的效果如下图所示。

Sub Count3Words()
    Dim oDic1 As Object, oDic2 As Object, oDic3 As Object
    Dim aProd, vProd, aWord, vWord, vKey, arrData
    Dim i As Long, sKey As String
    Set oDic1 = CreateObject("scripting.dictionary") ' product list by ONE word
    Set oDic2 = CreateObject("scripting.dictionary") ' product list by TWO words
    Set oDic3 = CreateObject("scripting.dictionary") ' product list by THREE words
    arrData = Range("A1").CurrentRegion.Value
    For i = LBound(arrData) + 1 To UBound(arrData)
        aWord = Split(arrData(i, 1))
        If UBound(aWord) > 1 Then
            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
        End If
    Next i
    For Each vKey In oDic1.keys
        aProd = Split(oDic1(vKey), ",")
        For Each vProd In aProd
            aWord = Split(vProd)
            For Each vWord In aWord
                If vWord <> vKey Then
                    sKey = SortWord(vKey & " " & vWord)
                    If oDic2.exists(sKey) Then
                        If InStr(1, oDic2(sKey), vProd, vbTextCompare) = 0 Then
                            oDic2(sKey) = oDic2(sKey) & "," & vProd
                        End If
                    Else
                        oDic2(sKey) = vProd
                    End If
                End If
            Next
        Next
    Next
    For Each vKey In oDic2.keys
        aProd = Split(oDic2(vKey), ",")
        For Each vProd In aProd
            aWord = Split(vProd)
            For Each vWord In aWord
                If InStr(1, vKey, vWord, vbTextCompare) = 0 Then
                    sKey = SortWord(vKey & " " & vWord)
                    If oDic3.exists(sKey) Then
                        If InStr(1, oDic3(sKey), vProd, vbTextCompare) = 0 Then
                            oDic3(sKey) = oDic3(sKey) & "," & vProd
                        End If
                    Else
                        oDic3(sKey) = vProd
                    End If
                End If
            Next
        Next
    Next
    For Each vKey In oDic3.keys
        oDic3(vKey) = UBound(Split(oDic3(vKey), ",")) + 1
    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
Function SortWord(ByVal sText As String) As String
    Dim i As Long, j As Long, aWord, sTmp As String
    aWord = Split(sText)
    If UBound(aWord) = 0 Then
        SortWord = sText
    Else
        For i = LBound(aWord) To UBound(aWord) - 1
            For j = i + 1 To UBound(aWord)
                If aWord(i) > aWord(j) Then
                    sTmp = aWord(i): aWord(i) = aWord(j): aWord(j) = sTmp
                End If
            Next
        Next
        SortWord = Join(aWord)
    End If
End Function

【代码解析】
对于代码中和 上一篇博客 相同的部分，此处就不做赘述。
第9~20行代码将根据每个单词（产品名称拆分）合并产品名称清单，保存在oDic1。
第21~38行代码将根据双词合并产品名称清单，保存在oDic2。

此处实现逻辑比双词要更复杂，例如：对于两个单词sWord1和sWord2，只有如下两种两种组合方式：

• sWord1 sWord2
• sWord2 sWord1

但是对于3个单词sWord1、sWord2和sWord3，有如下6种组合方式，但是这些组合包含的单词相同的，其词频统计的结果也是相同的，为了避免统计结果中的重复，需要对于单词组合进行排序，也就是说使用排序后的单词组合作为字典对象的键，确保单词组合的唯一性，如果使用升序排列，那么将采用第一种组合方法作为键。其中排序由自定义函数SortWord实现。

• sWord1 sWord2 sWord3
• sWord1 sWord3 sWord3
• sWord2 sWord1 sWord3
• sWord2 sWord3 sWord1
• sWord3 sWord1 sWord2
• sWord3 sWord2 sWord1

第39~56行代码将根据3词合并产品名称清单，保存在oDic3。
第44行代码判断单词是否存在与vKey中，避免3个单词组合中出现重复的单词。
第45行代码调用自定义函数将3个单词进行排序生成字典的键。
第46~52行代码更新oDic3中的键值对。
第57~59行代码根据字典对象中产品名称清单，统计3词组合的词频。
第60~63行代码将统计结果输出到工作表中。

第65~80行代码为自定义函数SortWord。
第67行代码使用空格作为分隔符将参数sText拆分为数组。
如果拆分后数组只有单个元素，说明sText不包含空格，那么无需进行排序，第68行代码将sText设置为函数返回值。
第71~77行代码使用冒泡法进行排序。
第74行代码实现数据组元素交换。
第78行代码将排序的数组元素合并为一个字符串。