本帖最后由 zyhui1961 于 2023-3-14 07:44 编辑
剑指E 发表于 2023-3-13 20:53
合并到一起不合适，单元格变动就要触发分级填充代码遍历 执行，将严重影响工作。
太耽误你的时间了，我真的都不好意思了。那这样行不：原来那个代码双击E6:G20区域单元格触发；这个代码双击H8:K25区域单元格触发，这样行不？谢谢！
说白了，就是把下面两个代码分别各加一个触发区域：
Private Sub Workbook_Sheetchange(ByVal Sh As Object, ByVal Target As Range)
Dim s$, i%, ar(), n As Byte, c As Range, nn As Byte, m&, cr, h As Boolean
For i = 1 To 128
If ActiveSheet.Name = Format(i, "000") Then h = True: Exit For
Next
If h = False Then Exit Sub
cr = Array(3, 5, 13, 7, 8, 10, 4)
For Each c In [B3:K200]
If InStr(c.Value, "(") Then
s = c
For i = 1 To Len(s)
If Mid(s, i, 1) = "(" Then
m = m + 10000
n = n + 1
ReDim Preserve ar(1 To 2, 1 To n)
ar(1, n) = m + i
ElseIf Mid(s, i, 1) = ")" Then
nn = nn + 1
ar(2, nn) = m + i
m = m - 10000
End If
Next
ReDim br(1 To n, 1 To 2)
For i = 1 To n
br(i, 1) = Application.Small(Application.Index(ar, 1, 0), i)
br(i, 2) = Application.Small(Application.Index(ar, 2, 0), i)
Next
For i = 1 To n
c.Characters(Start:=br(i, 1) Mod 10000, Length:=(br(i, 2) - br(i, 1)) Mod 10000 + 1).Font.ColorIndex = cr(br(i, 1) \ 10000 - 1)
Next
m = 0
n = 0
nn = 0
End If
Next
End Sub
Sub QCCC(Tg As Range)
Dim regx As Object, s$, i&, n, k As Byte, mat, m
s = Tg
s = Replace(Replace(Replace(s, "（", "("), "）", ")"), ":", "：")
For i = 1 To Len(s)
If Mid(s, i, 1) = "(" Then
n = n + 1
ElseIf Mid(s, i, 1) = ")" Then
n = n - 1
End If
If Mid(s, i, 1) = "：" And n > 0 Then s = Application.Replace(s, i, 1, ":")
Next
Set regx = CreateObject("vbscript.regexp")
With regx
.Global = True
.Pattern = "[一-龥]+："
Set mat = .Execute(s)
For Each m In mat
n = InStr(n + k + 1, s, m)
k = Len(m)
Tg.Characters(n, k).Font.ColorIndex = xlAutomatic
Next
End With
End Sub
|
楼主: zyhui1961
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-3-13 16:23
楼主
