Excel VBA高亮词计数需求及代码调试求助

首先看你遇到的问题：所有行F列都显示2，没有按行统计，核心原因有两个：

• 你在每次找到一个匹配时就立刻把整个CountArray写入F列，这会导致后续的统计更新被重复覆盖，最终只保留最后一次的错误结果。
• 另外，原代码中统计逻辑没有准确区分“每行”内的所有匹配（包括同一个单元格内的多次匹配）。

下面是修正后的完整代码，我会逐段解释关键修改点：

Sub HighlightAndCountMatches()
    Dim ws As Worksheet
    Dim SRrng As Range
    Dim mywords As Variant
    Dim m As Integer
    Dim c As Range
    Dim firstAddress As String
    Dim sPos As Long, sLen As Long
    Dim i As Long
    Dim CountArray() As Long ' 改用Long类型更稳妥，避免计数溢出
    Dim rowOffset As Long
    
    ' 明确指定工作表，避免Activate带来的问题
    Set ws = ThisWorkbook.Worksheets("Questions")
    Set SRrng = ws.Range("B2:E4000")
    
    ' 从用户窗体获取词汇数组，过滤空值（避免空字符串干扰统计）
    mywords = Array(UsrFormSearch.TxtSearch1.Value, _
                   UsrFormSearch.TxtSearch2.Value, _
                   UsrFormSearch.TxtSearch3.Value, _
                   UsrFormSearch.TxtSearch4.Value, _
                   UsrFormSearch.TxtSearch5.Value)
    ' 过滤数组中的空元素
    mywords = Filter(mywords, "", False)
    If UBound(mywords) = -1 Then Exit Sub ' 如果所有文本框都为空，直接退出
    
    ' 初始化计数数组，对应SRrng的每一行
    ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)
    
    For m = 0 To UBound(mywords)
        With SRrng
            Set c = .Find(mywords(m), LookIn:=xlValues, LookAt:=xlPart) ' 用xlPart匹配单元格内的子字符串
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ' 统计当前单元格内的匹配次数（处理同一个单元格内多个相同词汇的情况）
                    sLen = Len(mywords(m))
                    sPos = InStr(1, c.Value, mywords(m))
                    Do While sPos > 0
                        ' 高亮匹配内容
                        c.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                        c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
                        
                        ' 更新对应行的计数
                        rowOffset = c.Row - SRrng.Row + 1 ' 计算当前单元格在SRrng中的行索引
                        CountArray(rowOffset, 1) = CountArray(rowOffset, 1) + 1
                        
                        ' 移动到下一个匹配位置，避免重复统计同一个位置
                        sPos = InStr(sPos + sLen, c.Value, mywords(m))
                    Loop
                    
                    ' 查找下一个包含词汇的单元格
                    Set c = .FindNext(c)
                    ' 防止无限循环，回到第一个匹配单元格时退出
                    If c.Address = firstAddress Then Exit Do
                Loop While Not c Is Nothing
            End If
        End With
    Next m
    
    ' 所有统计完成后，一次性写入F列（对应SRrng的每一行）
    ws.Range("F2").Resize(SRrng.Rows.Count, 1).Value = CountArray
End Sub

关键修改点说明： #

• 移除Activate，明确指定工作表：用Set ws = ThisWorkbook.Worksheets("Questions")直接绑定工作表，避免因激活其他工作表导致的错误，代码更健壮。
• 过滤空词汇：用Filter(mywords, "", False)去掉数组中的空字符串，避免统计空值带来的无效计数。
• 修正计数数组的更新逻辑：不再每次匹配就写入F列，而是先在内存中完成所有行的统计，最后一次性写入F列，避免重复覆盖导致的错误。
• 准确处理单个单元格内的多次匹配：嵌套Do While sPos > 0循环，统计同一个单元格内所有出现的目标词汇，确保每个匹配都被计数。
• 修正行索引计算：用rowOffset = c.Row - SRrng.Row + 1准确计算当前单元格在SRrng中的行位置，保证计数对应到正确的行。
• Find方法指定LookAt:=xlPart：明确告诉Excel要匹配单元格内的子字符串，而不是整个单元格内容，符合你的需求。

现在运行这段代码，就能实现：

• 高亮B2:E4000内所有匹配用户窗体输入词汇的内容
• 每行的F列单元格准确统计该行内所有匹配词汇的总次数

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