如何修改Excel VBA代码实现2词、3词字符串的频次统计

大家好，我在Excel中做了如下设置：

我的核心需求是自动提取A列的所有字符串粘贴到H列，同时在I列返回对应字符串的出现频次，目前使用的VBA脚本如下：

Sub WordCountTester()
    Dim d As Object, k, i As Long, ws As Worksheet
    
    Set ws = ActiveSheet
    With ws.ListObjects("Table3")
        If Not .DataBodyRange Is Nothing Then
            .DataBodyRange.Delete
        End If
    End With
    Set d = WordCounts(ws.Range("A2:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row), _
                       ws.Range("F2:F" & ws.Cells(Rows.Count, "F").End(xlUp).Row))
    'list words and frequencies
    For Each k In d.keys
        ws.Range("H2").Resize(1, 2).Offset(i, 0).Value = Array(k, d(k))
        i = i + 1
    Next k
End Sub

'rngTexts = range with text to be word-counted, defined in set d= above
'rngExclude = 'range with words to exclude from count, defined in set d= above
Public Function WordCounts(rngTexts As Range, rngExclude As Range) As Object 'dictionary
    Dim words, c As Range, dict As Object, regexp As Object, w, wd As String, m
    Set dict = CreateObject("scripting.dictionary")
    Set regexp = CreateObject("VBScript.RegExp") 'see link below for reference
    With regexp
        .Global = True
        .MultiLine = True
        .ignorecase = True
        .Pattern = "[\dA-Z-]{3,}" 'at least 3 characters
     End With
     'loop over input range
     For Each c In rngTexts.Cells
        If Len(c.Value) > 0 Then
            Set words = regexp.Execute(LCase(c.Value))
            'loop over matches
            For Each w In words
                wd = w.Value 'the text of the match
                If Len(wd) > 1 Then  'EDIT: ignore single characters
                   'increment count if the word is not found in the "excluded" range
                    If IsError(Application.Match(wd, rngExclude, 0)) Then
                        dict(wd) = dict(wd) + 1
                    End If
                End If '>1 char
            Next w
        End If
            Next c
     Set WordCounts = dict
End Function

但当前代码仅支持统计1词字符串的频次，我需要调整为统计2词、3词字符串的频次（其中drive-by按2个词计算），同时保留F列的排除词功能，用于过滤不需要统计的2词、3词字符串。请问需要修改代码的哪一部分才能实现该需求？

你只需修改WordCounts函数的逻辑即可，核心修改点包括：

• 先把匹配到的带横杠的字符串拆分为独立单词，存入临时单词数组
• 遍历临时单词数组，生成连续的2词、3词组合
• 对生成的词组做排除校验后再统计频次

修改后的完整WordCounts函数代码如下：

Public Function WordCounts(rngTexts As Range, rngExclude As Range) As Object 'dictionary
    Dim words, c As Range, dict As Object, regexp As Object, w
    Dim tempWords() As String, wordIdx As Long, i As Long, phrase As String
    Set dict = CreateObject("scripting.dictionary")
    dict.CompareMode = vbTextCompare '不区分大小写
    Set regexp = CreateObject("VBScript.RegExp")
    With regexp
        .Global = True
        .MultiLine = True
        .ignorecase = True
        .Pattern = "[\dA-Z-]{3,}" '至少3个字符的匹配规则保留
     End With
     '遍历输入区域
     For Each c In rngTexts.Cells
        If Len(c.Value) > 0 Then
            Set words = regexp.Execute(LCase(c.Value))
            Erase tempWords
            wordIdx = 0
            '第一步：把所有匹配到的内容拆分横杠，存入临时单词数组
            For Each w In words
                Dim splitArr() As String
                splitArr = Split(Replace(w.Value, "-", " "), " ") '把横杠换成空格再拆分
                For i = LBound(splitArr) To UBound(splitArr)
                    If Len(Trim(splitArr(i))) >= 3 Then '过滤掉拆分后长度不足的内容
                        ReDim Preserve tempWords(wordIdx)
                        tempWords(wordIdx) = Trim(splitArr(i))
                        wordIdx = wordIdx + 1
                    End If
                Next
            Next w
            '第二步：生成2词、3词组合并统计
            If wordIdx >= 2 Then '至少有2个词才能生成词组
                '生成2词组合
                For i = 0 To wordIdx - 2
                    phrase = tempWords(i) & " " & tempWords(i + 1)
                    If IsError(Application.Match(phrase, rngExclude, 0)) Then
                        dict(phrase) = dict(phrase) + 1
                    End If
                Next
                '生成3词组合
                If wordIdx >= 3 Then
                    For i = 0 To wordIdx - 3
                        phrase = tempWords(i) & " " & tempWords(i + 1) & " " & tempWords(i + 2)
                        If IsError(Application.Match(phrase, rngExclude, 0)) Then
                            dict(phrase) = dict(phrase) + 1
                        End If
                    Next
                End If
            End If
        End If
     Next c
     Set WordCounts = dict
End Function

如果需要同时保留单字统计，只需在第二步代码后增加单字遍历统计的逻辑即可，WordCountTester主过程无需任何修改，原有F列排除词功能完全保留，只需把需要排除的2词/3词词组按原有格式填入F列即可生效。

内容的提问来源于stack exchange，提问作者Long N