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 添加到您的模塊中：

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