VBA for Excel代码来查找和更改单元格内的文本的子string的格式

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

• 采取一系列词语（称为Search_Terms ）

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

• 该function然后search单元格内的文本。

• 它查找与单元格中的Search_Terms中的单词匹配的所有子string，并更改它们的格式。

• 下面显示的function已经工作 。

• 但是，当我想要search几千个具有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）的build议closuresExcelfunction
• 设置使用的范围并捕获上次使用的列
• 迭代每列，并为每个单词应用自动筛选
• 如果有多个可见行（第一个是标题）
  • 遍历当前自动筛选列中的所有可见单元格
  • 检查单元格不包含错误＆不是空的（这个顺序，不同的检查）
  • 当它发现当前的过滤词做出改变
  • 移动到下一个单元格，然后再过滤一个单词，直到完成所有search单词
  • 移到下一列，重复上面的过程
• 清除所有filter，然后重新打开Excelfunction

---

 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使用新维度创build初始arr 的副本 ，然后删除第一个arr

另外，应该避免select和激活单元 – 大部分时间是不需要的，并减缓执行速度

---

编辑

我测量了两个版本之间的performance

 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

这里是closures大部分可以用来加速代码执行的VBA选项的代码。 启动时，节省当前状态; 然后把一切都closures。 在破坏时，它恢复当前的状态。

它作为一个应该重新命名的类模块input： 系统状态指令和信用在代码中。

 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