VBA for Excel 代码用于查找和更改单元格内文本子字符串的格式

Question

我正在为 Excel 使用 VBA。 我有执行以下操作的代码：

• 获取一个单词数组（称为Search_Terms）

• 然后我有一个函数（见下文），它接收Search_Terms 和对 Excel 中单元格的引用。

• 然后该函数搜索单元格内的文本。

• 它会在单元格中查找与Search_Terms 中的单词匹配的所有子字符串并更改其格式。

• 下面显示的功能已经可以工作了。

• 但是，当我想搜索包含 20 或 30 个单词的数组的数千个单元格时，速度很慢。

• 我想知道是否有一种更有效/更惯用的方法来做到这一点（我对 VBA 不是很熟悉，我只是在尝试破解）。

谢谢！

Dim Search_Terms As Variant
Dim starting_numbers() As Integer ' this is an "array?" that holds the starting position of each matching substring
Dim length_numbers() As Integer 'This is an "array" that holds the length of each matching substring

Search_Terms = Array("word1", "word2", "word3") 

Call change_all_matches(Search_Terms, c) ' "c" is a reference to a Cell in a Worksheet

Function change_all_matches(terms As Variant, ByRef c As Variant)
    ReDim starting_numbers(1 To 1) As Integer ' reset the array
    ReDim length_numbers(1 To 1) As Integer ' reset the array

    response = c.Value 

    ' This For-Loop Searches through the Text in the Cell and finds the starting position & length of each matching substring
    For Each term In terms ' Iterate through each term
        Start = 1
        Do
            pos = InStr(Start, response, term, vbTextCompare) 'See if we have a match
            If pos > 0 Then
                Start = pos + 1 ' keep looking for more substrings
                starting_numbers(UBound(starting_numbers)) = pos
                ReDim Preserve starting_numbers(1 To UBound(starting_numbers) + 1) As Integer  ' Add each matching "starting position" to our array called "starting_numbers"
                length_numbers(UBound(length_numbers)) = Len(term)
                ReDim Preserve length_numbers(1 To UBound(length_numbers) + 1) As Integer
            End If
        Loop While pos > 0  ' Keep searching until we find no substring matches
    Next


    c.Select 'Select the cell
    ' This For-Loop iterates through the starting position of each substring and modifies the formatting of all matches
    For i = 1 To UBound(starting_numbers)
        If starting_numbers(i) > 0 Then
                With ActiveCell.Characters(Start:=starting_numbers(i), Length:=length_numbers(i)).Font
                    .FontStyle = "Bold"
                    .Color = -4165632
                    .Size = 13
                End With
            End If
     Next i
     Erase starting_numbers
    Erase length_numbers
End Function

Answer 1

下面的代码可能会快一点（我没有测量过）

它的作用：

• 按照@Ron 的建议关闭 Excel 功能（ScreenUpdating、EnableEvents、Calculation）
• 设置使用范围并捕获最后使用的列
• 遍历每一列并对每个单词应用自动过滤器
• 如果有多个可见行（第一个是标题）
  • 遍历当前自动过滤列中的所有可见单元格
  • 检查单元格不包含错误且不为空（此顺序，不同检查）
  • 当它找到当前过滤词时进行更改
  • 移动到下一个单元格，然后是下一个过滤词，直到完成所有搜索词
  • 移至下一列，重复上述过程
• 清除所有过滤器，并重新启用 Excel 功能

---

Option Explicit

Const ALL_WORDS = "word1,word2,word3"

Public Sub ShowMatches()
    Dim ws As Worksheet, ur As Range, lc As Long, wrdArr As Variant, t As Double

    t = Timer
    Set ws = Sheet1
    Set ur = ws.UsedRange
    lc = ur.Columns.Count
    wrdArr = Split(ALL_WORDS, ",")
    enableXL False

    Dim c As Long, w As Long, cVal As String, sz As Long, wb As String
    Dim pos As Long, vr As Range, cel As Range, wrd As String

    For c = 1 To lc
        For w = 0 To UBound(wrdArr)
            If ws.AutoFilterMode Then ur.AutoFilter     'clear filters
            wrd = "*" & wrdArr(w) & "*"
            ur.AutoFilter Field:=c, Criteria1:=wrd, Operator:=xlFilterValues
            If ur.Columns(c).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
                For Each cel In ur.Columns(c).SpecialCells(xlCellTypeVisible)
                    If Not IsError(cel.Value2) Then
                        If Len(cel.Value2) > 0 Then
                            cVal = cel.Value2:  pos = 1
                            Do While pos > 0
                                pos = InStr(pos, cVal, wrdArr(w), vbTextCompare)
                                wb = Mid(cVal, pos + Len(wrdArr(w)), 1)
                                If pos > 0 And wb Like "[!a-zA-Z0-9]" Then
                                    sz = Len(wrdArr(w))
                                    With cel.Characters(Start:=pos, Length:=sz).Font
                                        .Bold = True
                                        .Color = -4165632
                                        .Size = 11
                                    End With
                                    pos = pos + sz - 1
                                Else
                                    pos = 0
                                End If
                            Loop
                        End If
                    End If
                Next
            End If
            ur.AutoFilter   'clear filters
        Next
    Next
    enableXL True
    Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

---

Private Sub enableXL(Optional ByVal opt As Boolean = True)
    Application.ScreenUpdating = opt
    Application.EnableEvents = opt
    Application.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
End Sub

---

您的代码在第一个循环中使用了ReDim Preserve（两次）

• 对单个电池的性能有轻微影响，但对数千个电池的性能影响很大

• ReDim Preserve使用新维度复制初始 arr，然后删除第一个 arr

此外，应避免选择和激活单元格 - 大多数时候不需要并减慢执行速度

---

编辑

我测量了两个版本之间的性能

Total cells: 3,060; each cell with 15 words, total search terms: 30

Initial code:               Time: 69.797 sec
My Code:                    Time:  3.969 sec
Initial code optimized:     Time:  3.438 sec

---

初始代码优化：

Option Explicit

Const ALL_WORDS = "word1,word2,word3"

Public Sub TestMatches()
    Dim searchTerms As Variant, cel As Range, t As Double

    t = Timer
    enableXL False
    searchTerms = Split(ALL_WORDS, ",")
    For Each cel In Sheet1.UsedRange
        ChangeAllMatches searchTerms, cel
    Next
    enableXL True
    Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

---

Public Sub ChangeAllMatches(ByRef terms As Variant, ByRef cel As Range)
    Dim termStart() As Long  'this array holds starting positions of each match
    Dim termLen() As Long    'this array holds lengths of each matching substring
    Dim response As Variant, term As Variant, strt As Variant, pos As Long, i As Long

    If IsError(cel.Value2) Then Exit Sub    'Do not process error
    If Len(cel.Value2) = 0 Then Exit Sub    'Do not process empty cells
    response = cel.Value2
    If Len(response) > 0 Then
        ReDim termStart(1 To Len(response)) As Long 'create arrays large enough
        ReDim termLen(1 To Len(response)) As Long   'to accommodate any matches
        i = 1: Dim wb As String
        'The loop finds the starting position & length of each matched term
        For Each term In terms              'Iterate through each term
            strt = 1
            Do
                pos = InStr(strt, response, term, vbTextCompare) 'Check for match
                wb = Mid(response, pos + Len(term), 1)
                If pos > 0 And wb Like "[!a-zA-Z0-9]" Then
                    strt = pos + 1          'Keep looking for more substrings
                    termStart(i) = pos      'Add match starting pos to array
                    termLen(i) = Len(term)  'Add match len to array termLen()
                    i = i + 1
                Else
                    pos = 0
                End If
            Loop While pos > 0  'Keep searching until we find no more matches
        Next
        ReDim Preserve termStart(1 To i - 1) 'clean up array
        ReDim Preserve termLen(1 To i - 1)   'remove extra items at the end
        For i = 1 To UBound(termStart) 'Modify matches based on termStart()
            If termStart(i) > 0 Then
                With cel.Characters(Start:=termStart(i), Length:=termLen(i)).Font
                    .Bold = True
                    .Color = -4165632
                    .Size = 11
                End With
            End If
        Next i
    End If
End Sub