VBA for Excel代码，用于查找和更改单元格中文本子字符串的格式
我正在使用VBA for Excel。 我有执行以下操作的代码：VBA for Excel代码，用于查找和更改单元格中文本子字符串的格式,vba,excel,Vba,Excel,我正在使用VBA for Excel。 我有执行以下操作的代码： 获取一个单词数组（称为Search\u Terms） 然后我有一个函数（见下文），它接收搜索词和Excel中单元格的引用 然后，该函数搜索单元格中的文本 它在单元格中查找与Search\u Terms中的单词匹配的所有子字符串，并更改其格式 下面显示的功能已经运行了 然而，当我想用20或30个单词的数组搜索几千个单元格时，速度相当慢 我想知道是否有一种更有效/更惯用的方法来实现这一点（我对VBA并不太熟悉，我只是在尝试一下）
- 获取一个单词数组（称为
）Search\u Terms - 然后我有一个函数（见下文），它接收
搜索词和Excel中单元格的引用 - 然后，该函数搜索单元格中的文本
- 它在单元格中查找与
中的单词匹配的所有子字符串，并更改其格式Search\u 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
下面的代码可能会快一点（我没有测量过） 它的作用是：
- 按照@Ron的建议关闭Excel功能（屏幕更新、启用事件、计算）
- 设置使用范围并捕获上次使用的列
- 遍历每列，并对每个单词应用自动筛选
- 如果有多个可见行（第一行是标题）
- 迭代当前自动筛选列中的所有可见单元格
- 检查单元格是否不包含错误且不为空（此顺序，不同检查）
- 当它找到当前过滤字时，会进行更改
- 移动到下一个单元格，然后移动下一个筛选词，直到所有搜索词都完成
- 移动到下一列，重复上述过程
- 清除所有过滤器，并重新打开Excel功能
您的代码在第一个循环中使用了
ReDim Preserve- 对一个单元的性能影响很小，但对数千个单元的性能影响很大
使用新维度复制初始arr的副本，然后删除第一个arrReDim Preserve
编辑 我测量了两个版本之间的性能
初始代码优化：
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
下面的代码关闭了可用于加快代码执行速度的大多数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
你的一些代码丢失了。但是，对于必须写入工作表的例程，通过关闭屏幕更新并将计算模式设置为手动，可以在一定程度上提高速度。另外，禁用事件。使用Long数据类型而不是整数可能会有一些改进，因为VBA会将整数转换为Long。@RonRosenfeld您是对的。部分代码丢失（如果造成混淆，请道歉）。绝对迷人。我不知道这些东西存在（屏幕更新、计算模式等）。非常感谢。
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
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