从字数组中突出显示 Substring

Question

此代码应该从用户表单上的两个文本框中进行搜索。 它遍历范围内的每个单元格，以检查文本框中的单词并以红色突出显示它们。

我无法让阵列工作。

Sub testing()
Worksheets("Search Results").Activate
Dim sPos As Long, sLen As Long
Dim SRrng As Range
Dim mywords As Variant
Dim i As Integer
Set SRrng = ActiveSheet.Range("A2:G1000")
mywords = Array(UsrFormTxtBox1, UserFormTextBox2)
For Each SRrng In SRrng
    With SRrng
        If SRrng.Value Like "*" & mywords & "*" Then
            If Not SRrng Is Nothing Then
                For i = 1 To Len(SRrng.Value)
                    sPos = InStr(i, SRrng.Value, mywords)
                    sLen = Len(mywords)
                    If (sPos <> 0) Then
                        SRrng.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                        SRrng.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
                        i = sPos + Len(mywords) - 1
                    End If
                Next i
            End If
        End If
    End With
Next SRrng
End Sub

Answer 1

只有两个小问题 - 首先是您的线路：

For Each SRrng In SRrng

...您需要声明第二个范围变量才能在第一个范围内浏览。 我称它为 cell （与Cells不同，它不是保留字）：

For Each cell In SRrng

其次，您的数组存储了两个必须单独处理的独立值。 我添加了一个变量m然后用它来循环遍历数组内容。 完整代码：

Sub testing()
    Worksheets("Search Results").Activate
    Dim sPos As Long, sLen As Long
    Dim SRrng As Range, cell As Range
    Dim mywords As Variant
    Dim i As Integer
    Set SRrng = ActiveSheet.Range("A2:G1000")
    mywords = Array(UsrFormTxtBox1, UserFormTextBox2)
    Dim m As Byte
    For m = 0 To UBound(mywords)
        For Each cell In SRrng
            With cell
             If cell.Value Like "*" & mywords(m) & "*" Then
                If Not cell Is Nothing Then
                           For i = 1 To Len(cell.Value)
                           sPos = InStr(i, cell.Value, mywords(m))
                           sLen = Len(mywords(m))
                           If (sPos <> 0) Then
                            cell.Characters(Start:=sPos, Length:=sLen).Font.Color = RGB(255, 0, 0)
                            cell.Characters(Start:=sPos, Length:=sLen).Font.Bold = True
                            i = sPos + Len(mywords(m)) - 1
                           End If
                           Next i
               End If
            End If
            End With
        Next cell
    Next m
End Sub

顺便说一句，您的代码很好，但如果您的范围变得非常大，那么使用Find会更快，如下所示：

Sub testing2()
    Worksheets("Search Results").Activate
    Dim sPos As Long, sLen As Long
    Dim SRrng As Range, cell As Range
    Dim mywords As Variant
    Dim i As Integer
    Set SRrng = ActiveSheet.Range("A2:G1000")
    mywords = Array(UsrFormTxtBox1, UserFormTextBox2)
    'mywords = Array("banana", "pear")
    Dim m As Byte
    Dim c As Range
    Dim firstAddress As String
    
    For m = 0 To UBound(mywords)
        With ActiveSheet.Range("A2:G1000")
            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
End Sub