Если вы хотите использовать отдельную процедуру, она может просмотреть желаемый диапазон и подсчитать количество слов, которые выделены жирным шрифтом в каждой ячейке, и записать итоговую сумму строки в конце каждой строки.
Вы можете использовать что-то вроде этого:
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 и задали расчет вручную, как описано здесь : Ускорение выполнения кода VBA для более быстрой работы
Другой вариант
Если этого недостаточно с точки зрения производительности, вы можете произвести подсчет во время форматирования. У вас может быть массив в виде одного столбца, в котором вы будете подсчитывать количество выделенных слов следующим образом:
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