Excel VBA计数突出显示的单词数

Question

我得到了帮助，让这段代码通过一个覆盖范围的数组突出显示用户表单中的某些单词。我想更进一步，通过计算单元格 B 到 E 之间突出显示的单词，并将颜色已更改的单词的出现次数放在 F 列中。有人可以指出我正确的方向吗所以我不会浪费时间走错路。非常感谢，

Worksheets("Search Results").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
'mywords = Array(UsrFormTxtBox1, UserFormTextBox2)
mywords = Array(UsrFormSearch.TxtSearch1.Value, UsrFormSearch.TxtSearch2.Value, UsrFormSearch.TxtSearch3.Value, UsrFormSearch.TxtSearch4.Value, UsrFormSearch.TxtSearch5.Value)
Dim m As Byte
Dim c As Range
Dim firstAddress As String
'Dim TotCount As Long

For m = 0 To UBound(mywords)
    With ActiveSheet.Range("B2:E4000")
    '1
        'TotCount = "0"
        Set c = .Find(mywords(m), LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                For i = 1 To Len(c.Value)
                    sPos = InStr(i, c.Value, mywords(m))
                    sLen = Len(mywords(m))
                    If (sPos <> 0) Then
                     c.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                     c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
                     i = sPos + Len(mywords(m)) - 1
                    End If
                Next i
            
                Set c = .FindNext(c)
                If firstAddress = c.Address Then Exit Do
                
            Loop While Not c Is Nothing
        End If
        
    End With
Next m

嗨 DecimalTurn，我尝试了以下操作，但是只是在范围之后的行中的每个单元格中获取数字 2，这是该范围内正确的字符串数，但随后没有移动到下一行并运行到最后当前行的。

Worksheets("Questions").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
'mywords = Array(UsrFormTxtBox1, UserFormTextBox2)
mywords = Array(UsrFormSearch.TxtSearch1.Value, UsrFormSearch.TxtSearch2.Value, UsrFormSearch.TxtSearch3.Value, UsrFormSearch.TxtSearch4.Value, UsrFormSearch.TxtSearch5.Value)
Dim m As Byte
Dim c As Range
Dim firstAddress As String
Dim CountArray() As Variant
ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)
'Dim TotCount As Long

For m = 0 To UBound(mywords)

    With ActiveSheet.Range("B2:E4000")
    '1
        'TotCount = "0"
        Set c = .Find(mywords(m), LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            
            Do
                For i = 1 To Len(c.Value)
                    sPos = InStr(i, c.Value, mywords(m))
                    sLen = Len(mywords(m))
                    If (sPos <> 0) Then
                   
                     c.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                     c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
                     i = sPos + Len(mywords(m)) - 1
                     'test
                     CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) + 1
                     SRrng.Cells(1, 1).Offset(0, SRrng.Columns.Count).Resize(1, UBound(CountArray, 1)).Value2 = CountArray
                     
                    End If
                    
                Next i
                    
                    
                Set c = .FindNext(c)
                If firstAddress = c.Address Then Exit Do
                
            Loop While Not c Is Nothing
            
        End If
        
    End With
Next m

Answer 1

如果您想使用单独的过程，它可以查看所需范围并计算每个单元格中粗体字的数量，并在每行末尾写下行总数。

你可以使用这样的东西：

Sub CountHighlightedWords()
    
    Dim ws As Worksheet
    Set ws = Worksheets("Search Results")
    Dim rng As Range
    Set rng = ws.Range("B2:E4000")
    
    Dim BoldArray() As Variant
    
    Dim Cell As Range, Row As Range
    Dim Character As Characters
    Dim SingleCell As Range
    
    Dim RowIndex As Long
    RowIndex = 0 'Reset
    
    For Each Row In rng.Rows
    
        RowIndex = RowIndex + 1
        
        Dim WordCounter As Long
        WordCounter = 0 'Reset
        
        Dim ColumnIndex As Long
        ColumnIndex = 0 'Reset
        
        For Each Cell In Row.Columns
            
            ColumnIndex = ColumnIndex + 1
            
            If Cell.Value2 <> vbNullString Then

                ReDim BoldArray(1 To Len(Cell.Value2)) 'Reset
                
                Dim i As Long
                For i = 1 To Len(Cell.Value2)
                   
                    If Cell.Characters(Start:=i, Length:=1).Font.Bold Then
                        BoldArray(i) = "1"
                    Else
                        BoldArray(i) = "0"
                    End If
                
                Next i
                
                'Count the number of clumps/islands of 1s in the array which corresponds to the number of words
                Dim str1 As String
                Dim arr1() As String
                str1 = Join(BoldArray, "")
                arr1() = Split(str1, "0")
                WordCounter = WordCounter + CountNonEmptyElements(arr1())
                Erase BoldArray
                
            End If
            
        Next Cell
        
        'Write the row total
        rng.Cells(1, 1).Offset(RowIndex - 1, ColumnIndex).Value2 = WordCounter
        
    Next
    
End Sub

并将以下函数添加到您的模块中：

Function CountNonEmptyElements(Arr() As String)

    Dim Counter As Long
    Dim i As Long
    
    For i = 1 To UBound(Arr)
        If Arr(i) <> vbNullString Then
            Counter = Counter + 1
        End If
    Next i
    
    CountNonEmptyElements = Counter
End Function

此代码循环遍历每个单元格并查看每个字符，因此根据单元格的数量和文本的数量，它可能会有点慢。

如果性能是一个问题，请确保您打开 Application.ScreenUpdating 并将计算设置为手动，如下所述：Speeding up VBA Code to Run Faster

其他选择

如果这在性能方面还不够，那么您可以在格式化时进行计数。您可以有一个单列形状的数组，您可以在其中计算突出显示的单词的数量，如下所示：

Dim CountArray() as Variant
ReDim CountArray(1 to SRrng.Rows.Count, 1 to 1)

并且每次将粗体格式应用于单元格中的单词时，都可以增加数组中的相应元素（对于该行）。

CountArray(c.Row - SRrng.Cells(1,1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1,1).Row + 1, 1) + 1

当所有替换完成后，您可以将数组的内容写入您覆盖的范围右侧的列中。

SRrng.Cells(1,1).Offset(0,SRrng.Columns.Count).Resize(Ubound(CountArray,1),1).Value2 = CountArray

因此，如果我们将所有这些放在您的代码中，那将如下所示：

Worksheets("Questions").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range, cell2 As Range
Dim mywords As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("B2:E4000")
'mywords = Array(UsrFormTxtBox1, UserFormTextBox2)
mywords = Array(UsrFormSearch.TxtSearch1.Value, UsrFormSearch.TxtSearch2.Value, UsrFormSearch.TxtSearch3.Value, UsrFormSearch.TxtSearch4.Value, UsrFormSearch.TxtSearch5.Value)
Dim m As Byte
Dim c As Range
Dim firstAddress As String

Dim CountArray() As Variant
ReDim CountArray(1 To SRrng.Rows.Count, 1 To 1)

For m = 0 To UBound(mywords)

        Set c = SRrng.Find(mywords(m), LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            
            Do
                For i = 1 To Len(c.Value)
                    sPos = InStr(i, c.Value, mywords(m))
                    sLen = Len(mywords(m))
                    If (sPos <> 0) Then
                   
                     c.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                     c.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
                     i = sPos + Len(mywords(m)) - 1
                     CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) = CountArray(c.Row - SRrng.Cells(1, 1).Row + 1, 1) + 1
                     
                    End If
                    
                Next i
                    
                    
                Set c = .FindNext(c)
                If firstAddress = c.Address Then Exit Do
                
            Loop While Not c Is Nothing
            
        End If
        
Next m

    SRrng.Cells(1, 1).Offset(0, SRrng.Columns.Count).Resize(UBound(CountArray, 1), 1).Value2 = CountArray