修改代码增加区域选择，文字及括号颜色定义对话框：
完整代码：
Option Explicit
Function ConvertColor(ByVal colorStr As String, ByRef colorOut As Long) As Boolean
Dim arrColor
arrColor = Split(colorStr, ",")
If UBound(arrColor) <> 2 Then
MsgBox "颜色格式错误，请使用R,G,B格式！", vbCritical
ConvertColor = False
Exit Function
End If
On Error Resume Next
Dim r As Long: r = CLng(Trim(arrColor(0)))
Dim g As Long: g = CLng(Trim(arrColor(1)))
Dim b As Long: b = CLng(Trim(arrColor(2)))
On Error GoTo 0
If r < 0 Or r > 255 Or g < 0 Or g > 255 Or b < 0 Or b > 255 Then
MsgBox "颜色数值必须在0-255之间！", vbCritical
ConvertColor = False
Exit Function
End If
colorOut = RGB(r, g, b)
ConvertColor = True
End Function
Sub OptimizedColorAllTextInBrackets()
Dim targetRange As Range
Dim cell As Range
Dim text As String
Dim startPos As Long, endPos As Long
Dim arrBrackets() As Variant
Dim i As Long
Dim defaultTextColor As Long
Dim bracketTextColor As Long
Dim colorInput As String
' 选择处理区域
On Error Resume Next
Set targetRange = Application.InputBox("请选择要处理的区域", "区域选择", "F4:K10000", Type:=8)
On Error GoTo 0
If targetRange Is Nothing Then Exit Sub
' 过滤空单元格
On Error Resume Next
Set targetRange = targetRange.SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If targetRange Is Nothing Then
MsgBox "所选区域没有内容！", vbInformation
Exit Sub
End If
' 颜色选择
colorInput = InputBox("普通文字颜色（格式：R,G,B）", "颜色选择", "0,0,0")
If Not ConvertColor(colorInput, defaultTextColor) Then Exit Sub
colorInput = InputBox("括号文字颜色（格式：R,G,B）", "颜色选择", "0,0,255")
If Not ConvertColor(colorInput, bracketTextColor) Then Exit Sub
' 优化性能设置
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.EnableAnimations = False
End With
For Each cell In targetRange
' 处理括号着色
text = cell.Value
cell.Font.Color = defaultTextColor ' 设置整体文字颜色
If InStr(text, "【") > 0 Then
ReDim arrBrackets(1 To Len(text) \ 2)
startPos = InStr(text, "【")
i = 0
Do While startPos > 0
endPos = InStr(startPos + 1, text, "】")
If endPos > startPos Then
i = i + 1
arrBrackets(i) = Array(startPos, endPos - startPos + 1)
startPos = InStr(endPos + 1, text, "【")
Else
Exit Do
End If
Loop
If i > 0 Then
For startPos = 1 To i
With cell.Characters(arrBrackets(startPos)(0), arrBrackets(startPos)(1)).Font
.Color = bracketTextColor
End With
Next startPos
End If
End If
Next cell
' 恢复系统设置
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.EnableAnimations = True
End With
MsgBox "处理完成！共处理 " & targetRange.Count & " 个单元格", vbInformation
End Sub
自动运行代码：
' Worksheet_Change事件处理
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrorHandler
Application.EnableEvents = False
' 限制处理范围并提升性能
Dim ProcessArea As Range
Set ProcessArea = Me.Range("F4:K10000")
' 仅处理与目标区域有交集的单元格
Dim cell As Range
For Each cell In Intersect(Target, ProcessArea)
' 排除空单元格和错误值
If Not IsError(cell.Value) Then
' 移除原有的0值处理逻辑
If InStr(cell.Value, "【") > 0 Then
UpdateBracketColor cell, RGB(0, 0, 0), RGB(0, 0, 255)
End If
End If
Next cell
ExitHandler:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
MsgBox "处理过程中发生错误：" & Err.Description & vbCrLf & "错误代码：" & Err.Number
Resume ExitHandler
End Sub
' 优化后的括号处理函数
Private Sub UpdateBracketColor(ByVal cell As Range, ByVal defColor As Long, ByVal brkColor As Long)
On Error Resume Next ' 防止合并单元格出错
Dim text As String
text = cell.Value
cell.Font.Color = defColor
' 使用更高效的查找算法
Dim posOpen As Long, posClose As Long
posOpen = InStr(1, text, "【")
Do While posOpen > 0
posClose = InStr(posOpen + 1, text, "】")
If posClose > 0 Then
With cell.Characters(posOpen, posClose - posOpen + 1).Font
.Color = brkColor
End With
posOpen = InStr(posClose + 1, text, "【")
Else
Exit Do
End If
Loop
End Sub
