使用VBA统计产品名称中重复出现的三字词组

我有一个Excel工作簿，A列包含超过10万条产品名称，需要统计词组内单词顺序无关的三字词组在多少个产品中出现（例如统计“blue hyundai car”出现在多少个产品里）。我基于Stack Overflow用户taller的双字词组统计VBA代码进行修改，得到以下代码：

Sub everythingg()
    Dim ws As Worksheet
    Dim lastRowA As Long
    Dim productNamesArray() As Variant
    Dim i As Long, j As Long
    Dim oDic1 As Object, oDic2 As Object, oDic3 As Object
    Dim sKey1 As String, sKey2 As String, sortedKey As String
    Dim Word As Variant, ProductName As Variant, PN As Variant
    Dim productWordsArray As Variant, PWordArray As Variant

    ' 初始化字典
    Set oDic1 = CreateObject("scripting.dictionary")
    Set oDic2 = CreateObject("scripting.dictionary")
    Set oDic3 = CreateObject("scripting.dictionary")

    ' 指定工作表并获取A列最后一行数据行号
    Set ws = ThisWorkbook.Sheets("Productos")
    lastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------

    '---------------创建产品名称数组-----------------------------------------
    ' 调整数组大小以匹配数据行数
    ReDim productNamesArray(1 To lastRowA - 1)
    
    ' 从A列第2行开始填充产品名称数组
    For i = 2 To lastRowA
        productNamesArray(i - 1) = ws.Cells(i, 1).Value
        Debug.Print "productNamesArray(" & i - 1 & ") : "; productNamesArray(i - 1)
    Next i
    
    Debug.Print
 
    
'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------

    '------------创建产品单词数组------------------------
    For i = 1 To UBound(productNamesArray)
        ' 拆分产品名称为单词数组
        productWordsArray = Split(productNamesArray(i), " ")
        
         ' 在立即窗口打印单词
        For j = LBound(productWordsArray) To UBound(productWordsArray)
            Debug.Print "ProductWordsArray(" & j & "): " & productWordsArray(j)
        Next j
        Debug.Print

        '---- 将单词加入oDic1，并关联对应的产品名称 ----
        Debug.Print "获取productWordsArray中的每个单词，添加或更新到oDIC1"
        For Each Word In productWordsArray
            If oDic1.Exists(Word) Then
                oDic1(Word) = oDic1(Word) & "," & productNamesArray(i)
                Debug.Print "更新: " & Word & " - " & oDic1(Word)
            Else
                oDic1(Word) = productNamesArray(i)
                Debug.Print "新增: " & Word & " - " & oDic1(Word)
            End If
        Next
        Debug.Print
    Next i
    Debug.Print
    
'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------

    Debug.Print "循环结束后oDic1的内容:"
    For Each Key In oDic1.Keys
        Debug.Print Key & ": " & oDic1(Key)
    Next Key
    Debug.Print
       

'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------
'----------------------------------------------------------------------------------------
    '<-- 拆分oDic1中每个键对应的产品名称为数组-->
    Debug.Print "拆分oDIC1中每个键对应的产品名称"
    Debug.Print
    
    For Each Key In oDic1.Keys
        ' 获取产品名称数组
        ProductName = Split(oDic1(Key), ",")
        Debug.Print Key

        For i = LBound(ProductName) To UBound(ProductName)
            Debug.Print "ProductName(" & i & "): " & ProductName(i)
        Next i
        Debug.Print

        '<----创建产品名称对应的单词数组---->'
        oDic2.RemoveAll  '按关键词统计单词出现次数
        Debug.Print "创建产品名称对应的单词数组"

        ' 拆分每个产品名称为单词数组
        For Each PN In ProductName
            PWordArray = Split(PN)
            
            ' 在立即窗口打印每个单词
            For i = LBound(PWordArray) To UBound(PWordArray)
                Debug.Print "PWordArray(" & i & "): " & PWordArray(i)
            Next i
            Debug.Print

            '<----- 将单词加入oDIC2并计数 ----->'
            Debug.Print "添加或更新oDIC2并计数"
            For Each vWord In PWordArray
                If oDic2.Exists(vWord) Then
                    oDic2(vWord) = oDic2(vWord) + 1
                    Debug.Print "更新: " & vWord & " - 计数: " & oDic2(vWord)
                Else
                    oDic2(vWord) = 1
                    Debug.Print "新增: " & vWord & " - 计数: 1"
                End If
            Next
        Next
        Debug.Print
        '------------------------------------------------
        Debug.Print "oDic2的内容（关键词：" & Key & "）:"
        For Each vWord In oDic2.Keys
            Debug.Print vWord & ": " & oDic2(vWord)
        Next
        Debug.Print
    
    
    
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------
 Debug.Print "统计三字词组"
' 生成所有不重复的三字单词组合
Dim wordList As Variant, w1 As Variant, w2 As Variant, w3 As Variant
wordList = oDic2.Keys
For i = 0 To UBound(wordList) - 2
    w1 = wordList(i)
    If w1 = Key Then GoTo SkipW1
    For j = i + 1 To UBound(wordList) - 1
        w2 = wordList(j)
        If w2 = Key Then GoTo SkipW2
        For k = j + 1 To UBound(wordList)
            w3 = wordList(k)
            If w3 = Key Then GoTo SkipW3
            
            ' 生成排序后的词组键，保证顺序无关
            Dim tempArr(2) As String
            tempArr(0) = w1: tempArr(1) = w2: tempArr(2) = w3
            sortedKey = GetSortedKey(tempArr)
            
            Debug.Print "当前三字词组: " & sortedKey
            Debug.Print "添加或更新到oDic3"
            If oDic3.Exists(sortedKey) Then
                If oDic2(w3) > oDic3(sortedKey) Then
                    Debug.Print "更新词组: " & sortedKey & " - 计数: " & oDic2(w3)
                    oDic3(sortedKey) = oDic2(w3)
                Else
                    Debug.Print "不更新词组: " & sortedKey
                End If
            Else
                Debug.Print "新增词组: " & sortedKey & " - 计数: " & oDic2(w3)
                oDic3(sortedKey) = oDic2(w3)
            End If
SkipW3:
        Next k
SkipW2:
    Next j
SkipW1:
Next i
Next
    
    ' 将统计结果输出到工作表C、D列
    ws.Range("C1") = "三字词组"
    ws.Range("D1") = "出现产品数"
    i = 2
    For Each sortedKey In oDic3.Keys
        ws.Cells(i, "C") = sortedKey
        ws.Cells(i, "D") = oDic3(sortedKey)
        i = i + 1
    Next sortedKey
End Sub

' 辅助函数：生成排序后的词组键，确保顺序无关
Function GetSortedKey(arr() As String) As String
    Dim i As Long, j As Long, temp As String
    ' 冒泡排序数组
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If arr(i) > arr(j) Then
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
            End If
        Next j
    Next i
    GetSortedKey = arr(0) & " " & arr(1) & " " & arr(2)
End Function

内容的提问来源于stack exchange，提问作者Francisco Augusto Varela Aguir