Excel VBA 计数突出显示的字数

Question

I had help getting this code to work which highlights certain words from a userform via an array covering a range. I wanted to take this a step further by counting the words that have been highlighted between cells B to E and and place the number of occurrence of the words where the colour has been changed in column F. Can someone point me in the right direction please so i dont waste days going down the wrong alley. Many thanks,

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

Hi DecimalTurn, i tried the following, however just getting the number 2 in every cell on the row after the range which is the correct number of strings in the range, but then not moving to the next row and running to the end of the current row.

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

If you'd like to use a seperate procedure, it could look over the desired range and count the number of words than are in bold in each cells and write the row total at the end of each row.

You could use something like this:

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

And add the following function to your module as well:

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

This code is looping over every cell and looking at every character, so it might be a little slow depending on the number of cells and the quantity of text.

If performance is an issue, make sure that you turn of Application.ScreenUpdating and set the calculation to manual as discussed here: Speeding up VBA Code to Run Faster

Other alternative

If this is not enough in terms of performance, then you could do the counting while you format. You could have a single-column-shaped array where you would count the number of highlighted words like this:

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

And every time you apply the bold formatting to a word in a cell, you could increase the corresponding element in the array (for that row).

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

When all the replacements are done, you could then write the content of the array to the column to the right of the range you covered.

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

So, if we put all this together in your code, that would look like this:

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