Excel VBA代码修改：统计产品名中重复连续词对及出现次数

问题背景 #

• 处理超10万条产品名称数据，目标是识别并统计所有连续相邻词对的出现次数
• 已实现单个词的重复统计，但现有词对统计代码输出结果不符合预期，需修正

单个词重复统计代码（可正常运行） #

Sub FindAndCountWords()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim wordsDict As Object
    
    ' 创建字典存储单词及出现次数
    Set wordsDict = CreateObject("Scripting.Dictionary")
    
    ' 指定工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 获取A列最后一行行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历A列数据（从A2开始）
    For Each cell In ws.Range("A2:A" & lastRow)
        ' 将单元格内容按空格分割为单词数组
        Dim wordsArray As Variant
        wordsArray = Split(cell.Value, " ")
        
        ' 遍历单词数组，更新字典计数
        For Each word In wordsArray
            If wordsDict.Exists(word) Then
                wordsDict(word) = wordsDict(word) + 1
            Else
                wordsDict.Add word, 1
            End If
        Next word
    Next cell
    
    ' 将结果输出到C、D列
    ws.Range("C2").Resize(wordsDict.Count, 1).Value = Application.WorksheetFunction.Transpose(wordsDict.Keys)
    ws.Range("D2").Resize(wordsDict.Count, 1).Value = Application.WorksheetFunction.Transpose(wordsDict.Items)
End Sub

原词对统计代码的问题 #

原代码使用双层嵌套循环遍历所有非相邻的词对组合，而非连续相邻的词对，这是输出不符合预期的核心原因：

' 原错误逻辑：遍历所有词对组合，而非连续相邻词对
For i = 1 To UBound(wordsArray)
    For j = i + 1 To UBound(wordsArray)
        Dim pair As String
        pair = wordsArray(i) & " " & wordsArray(j)
        ' ... 更新字典
    Next j
Next i

修正后的连续词对统计代码 #

Sub FindAndCountWordPairs()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim pairsDict As Object
    Dim wordsArray As Variant
    Dim i As Long
    Dim pair As String
    
    ' 创建字典存储连续词对及出现次数
    Set pairsDict = CreateObject("Scripting.Dictionary")
    ' 指定工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' 获取A列最后一行行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 优化性能：关闭屏幕更新、事件触发
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 遍历A列数据（从A2开始）
    For Each cell In ws.Range("A2:A" & lastRow)
        If Trim(cell.Value) <> "" Then ' 跳过空单元格
            wordsArray = Split(cell.Value, " ")
            ' 遍历数组，仅取连续相邻的词对
            For i = LBound(wordsArray) To UBound(wordsArray) - 1
                pair = wordsArray(i) & " " & wordsArray(i + 1)
                ' 更新字典计数
                If pairsDict.Exists(pair) Then
                    pairsDict(pair) = pairsDict(pair) + 1
                Else
                    pairsDict.Add pair, 1
                End If
            Next i
        End If
    Next cell
    
    ' 将结果输出到F、G列
    If pairsDict.Count > 0 Then
        ws.Range("F2").Resize(pairsDict.Count, 1).Value = Application.WorksheetFunction.Transpose(pairsDict.Keys)
        ws.Range("G2").Resize(pairsDict.Count, 1).Value = Application.WorksheetFunction.Transpose(pairsDict.Items)
    End If
    
    ' 恢复系统设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

关键修改说明 #

1. 循环逻辑调整：将双层循环改为单层循环，遍历从数组第一个元素到倒数第二个元素，每次取当前元素和下一个元素组成连续词对
2. 空值处理：增加空单元格判断，避免无效计算
3. 性能优化：针对10万条数据的规模，添加屏幕更新、事件禁用的优化，提升运行速度

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