关于字符串文字匹配的问题

美味海鲜派

附件中自己做了个循环的，就是速度太慢，求大神优化，谢谢。

字符串涂色.rar (26.6 KB, 下载次数: 31)

2018-1-24 12:01 上传

点击文件名下载附件

liulang0808

代码供参考，

美味海鲜派

liulang0808 发表于 2018-1-24 13:04
代码供参考，

谢谢，速度提升不少，用字典先排列组合，开阔了思路。不知道还有没有更快的

aman1516

字典减少重复元素的循环处理（非常好的一个思路，虽然本例要匹配的字符串中无重复字符），相关数据读入数组再处理……数据量少时不明显，数据量大时则差别非常大了！

lbpp

Sub 涂色_lbpp()

    Const C_RED As Long = -16776961

    Dim sRE_Pattern As String
    Dim objReg As Object
    Set objReg = CreateObject("Vbscript.Regexp")

    sRE_Pattern = Application.InputBox("请选择特征字符串", , , , , , , 8)
   
    sRE_Pattern = Replace(sRE_Pattern, "?", "\?")       '之前未考虑到?是正则表达式的元字符，因此要加\转义为普通字符
    sRE_Pattern = "[" & sRE_Pattern & "]"


    With objReg
        .Global = True
        .Pattern = sRE_Pattern
    End With

    Dim rngProc As Range
    Set rngProc = Application.InputBox("请选择处理的数据区域", , , , , , , 8)

    Dim rngTemp As Range

    Dim mc As Object
    Dim m As Object

    Application.ScreenUpdating = False

    For Each rngTemp In rngProc

        Set mc = objReg.Execute(rngTemp.Value)
        For Each m In mc
        
            ' 之前未仔细测试，FirstIndex返回的是从0开始的，因此此处需+1
            rngTemp.Characters(Start:=m.FirstIndex + 1, Length:=1).Font.Color = C_RED
        Next m
    Next rngTemp

    Application.ScreenUpdating = True

End Sub

lbpp

用正则写了一个，供参考。
楼下提到的匹配不正确已修改。
？没有匹配到的原因是？在正则表达式中是元字符（类似保留字），因此需要使用\来转义为普通字符。

另外匹配到的字符索引是从0开始的，因此在设置红字时需偏移1。

美味海鲜派

lbpp 发表于 2018-1-24 15:02
用正则写了一个，供参考。

看到了，正则不是很懂，研究一下，谢谢！

aman1516

lbpp 发表于 2018-1-24 15:02
用正则写了一个，供参考。

匹配有错，希望修正，学习下正则，对比下速度如何。
另外 ，liulang0808 版主的代码，有部分“是”字没识别出来，不知是否我抄错代码了？

aman1516

liulang0808 发表于 2018-1-24 13:04
代码供参考，

发现问题了，只要是？后面的一个字，就算是匹配字符，也不会变颜色，不知为什么？
另外，字典值改了下，应该更全面些，速度也更快些：

1. For j = 1 To Len(arr(2, 1))
   
2.     d(Mid(arr(2, 1), j, 1)) = ""
   
3.     For i = 1 To Len(arr(2, 1)) - j + 1
   
4.          d(Mid(arr(2, 1), j, i)) = ""
   
5.     Next i
   
6. Next j

复制代码

lbpp

aman1516 发表于 2018-1-24 16:27
匹配有错，希望修正，学习下正则，对比下速度如何。
另外 ，liulang0808 版主的代码，有部分“是”字没 ...

代码已修正，审核通过后就能看到。