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

Question

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

• 获取一系列单词（称为Search_Terms）

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

• 然后该功能搜索单元格内的文本。

• 它会找到与单元格中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（ScreenUpdating，EnableEvents，Calculation）的建议关闭Excel功能
• 设置使用的范围并捕获上次使用的列
• 遍历每一列并为每个单词
应用AutoFilter
• 如果有多个可见行（第一个是标题）
  • 遍历当前自动过滤的列中的所有可见单元格
  • 检查单元格是否包含错误＆amp;不是空的（这个顺序，不同的检查）
  • 当找到当前过滤词进行更改时
  • 移动到下一个单元格，然后下一个过滤单词，直到所有搜索单词都完成
  • 移至下一栏，重复上述过程
• 清除所有过滤器，然后重新启用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

Answer 2

以下代码可以关闭大多数可用于加速代码执行的VBA选项。在启动时，它保存当前状态;然后关掉一切。在破坏时，它会恢复当前的状态。

它作为应该重新命名的类模块输入： SystemState 说明和信用在代码中。

Option Explicit

'
'This class has been developed by my friend & colleague Jon Tidswell.
'I just changed it slightly. Any errors are mine for sure.
'13-Apr-2010 Bernd Plumhoff
'
'The class is called SystemState.
'It can of course be used in nested subroutines.
'
'This module provides a simple way to save and restore key excel
'system state variables that are commonly changed to speed up VBA code
'during long execution sequences.
'
'
'Usage:
'    Save() is called automatically on creation and Restore() on destruction
'    To create a new instance:
'        Dim state as SystemState
'        Set state = New SystemState
'    Warning:
'        "Dim state as New SystemState" does NOT create a new instance
'
'
'    Those wanting to do complicated things can use extended API:
'
'    To save state:
'       Call state.Save()
'
'    To restore state and in cleanup code: (can be safely called multiple times)
'       Call state.Restore()
'
'    To restore Excel to its default state (may upset other applications)
'       Call state.SetDefaults()
'       Call state.Restore()
'
'    To clear a saved state (stops it being restored)
'       Call state.Clear()
'
Private Type m_SystemState
    Calculation As XlCalculation
    Cursor As XlMousePointer
    DisplayAlerts As Boolean
    EnableEvents As Boolean
    Interactive As Boolean
    ScreenUpdating As Boolean
    StatusBar As Variant
    m_saved As Boolean
End Type

'
'Instance local copy of m_State?
'
Private m_State As m_SystemState

'
'Reset a saved system state to application defaults
'Warning: restoring a reset state may upset other applications
'
Public Sub SetDefaults()
    m_State.Calculation = xlCalculationAutomatic
    m_State.Cursor = xlDefault
    m_State.DisplayAlerts = True
    m_State.EnableEvents = True
    m_State.Interactive = True
    m_State.ScreenUpdating = True
    m_State.StatusBar = False
    m_State.m_saved = True ' effectively we saved a default state
End Sub

'
'Clear a saved system state (stop restore)
'
Public Sub Clear()
    m_State.m_saved = False
End Sub

'
'Save system state
'
Public Sub Save(Optional SetFavouriteParams As Boolean = False)
    If Not m_State.m_saved Then
        m_State.Calculation = Application.Calculation
        m_State.Cursor = Application.Cursor
        m_State.DisplayAlerts = Application.DisplayAlerts
        m_State.EnableEvents = Application.EnableEvents
        m_State.Interactive = Application.Interactive
        m_State.ScreenUpdating = Application.ScreenUpdating
        m_State.StatusBar = Application.StatusBar
        m_State.m_saved = True
    End If
    If SetFavouriteParams Then
        Application.Calculation = xlCalculationManual
        'Application.Cursor = xlDefault
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        'Application.Interactive = False
        Application.ScreenUpdating = False
        Application.StatusBar = False
    End If
End Sub

'
'Restore system state
'
Public Sub Restore()
    If m_State.m_saved Then
        Application.Calculation = m_State.Calculation
        Application.Cursor = m_State.Cursor
        Application.DisplayAlerts = m_State.DisplayAlerts
        Application.EnableEvents = m_State.EnableEvents
        Application.Interactive = m_State.Interactive
        Application.ScreenUpdating = m_State.ScreenUpdating
        If m_State.StatusBar = "FALSE" Then
            Application.StatusBar = False
        Else
            Application.StatusBar = m_State.StatusBar
        End If
    End If
End Sub

'
'By default save when we are created
'
Private Sub Class_Initialize()
    Call Save(True)
End Sub

'
'By default restore when we are destroyed
'
Private Sub Class_Terminate()
    Call Restore
End Sub