关于VBA中使用正则表达式进行替换的性能问题?

jsjcjsjc

这段是在网上抄的代码,测试了一下是可以的

1. Sub ABAB_AB()
   
2. 
   
3.     Dim RegExp As Object
   
4.     Dim SearchRange As Range, Cell As Range
   
5.    
   
6.     '此处定义正则表达式
   
7.     Set RegExp = CreateObject("vbscript.regexp")
   
8.     RegExp.Pattern = "(.)(?!\1)(.)\1\2"
   
9.      
   
10.     '此处指定查找范围
    
11.     Set SearchRange = ActiveSheet.Range("B2:B42558")
    
12.    
    
13.     '遍历查找范围内的单元格
    
14.     For Each Cell In SearchRange
    
15.         Set Matches = RegExp.Execute(Cell.Value)
    
16.         If Matches.Count >= 1 Then
    
17.             Set Match = Matches(0)
    
18.             Cell.Value = RegExp.Replace(Cell.Value, "$1$2")
    
19.         End If
    
20.     Next
    
21. 
    
22. End Sub

复制代码

后来我自己改了一下,大概是这样的,发现性能很不行啊
可以看一下我的附件,如果是只有几个的话没有问题,但是数量一多(最后一确定按钮),整个就是死机的感觉啊,求大神优化啊
先感谢了

1. Sub ABAB_AB()
   
2. 
   
3.     Dim RegExp As Object
   
4.     Dim SearchRange As Range, Cell As Range
   
5.    
   
6.     '此处定义正则表达式
   
7.     Set RegExp = CreateObject("vbscript.regexp")
   
8.     RegExp.Pattern = "(.)(?!\1)(.)\1\2"
   
9.      
   
10.     '此处指定查找范围
    
11.     Set SearchRange = ActiveSheet.Range("B2:B42558")
    
12.    
    
13.     '遍历查找范围内的单元格
    
14.     For Each Cell In SearchRange
    
15.         Set Matches = RegExp.Execute(Cell.Value)
    
16.         If Matches.Count >= 1 Then
    
17.             Set Match = Matches(0)
    
18.             Cell.Value = RegExp.Replace(Cell.Value, "$1$2")
    
19.         End If
    
20.     Next
    
21. 
    
22. End Sub
    
23. Sub ABB_ABBB()
    
24. 
    
25.     Dim RegExp As Object
    
26.     Dim SearchRange As Range, Cell As Range
    
27.    
    
28.     '此处定义正则表达式
    
29.     Set RegExp = CreateObject("vbscript.regexp")
    
30.     RegExp.Pattern = "(.)(?!\1)(.)\2"
    
31.      
    
32.     '此处指定查找范围
    
33.     Set SearchRange = ActiveSheet.Range("F2:F42558")
    
34.    
    
35.     '遍历查找范围内的单元格
    
36.     For Each Cell In SearchRange
    
37.         Set Matches = RegExp.Execute(Cell.Value)
    
38.         If Matches.Count >= 1 Then
    
39.             Set Match = Matches(0)
    
40.             Cell.Value = RegExp.Replace(Cell.Value, "$1$2$2$2")
    
41.         End If
    
42.     Next
    
43. 
    
44. End Sub
    
45. Sub ABB_AAB()
    
46. 
    
47.     Dim RegExp As Object
    
48.     Dim SearchRange As Range, Cell As Range
    
49.    
    
50.     '此处定义正则表达式
    
51.     Set RegExp = CreateObject("vbscript.regexp")
    
52.     RegExp.Pattern = "(.)(?!\1)(.)\2"
    
53.      
    
54.     '此处指定查找范围
    
55.     Set SearchRange = ActiveSheet.Range("J2:J42558")
    
56.    
    
57.     '遍历查找范围内的单元格
    
58.     For Each Cell In SearchRange
    
59.         Set Matches = RegExp.Execute(Cell.Value)
    
60.         If Matches.Count >= 1 Then
    
61.             Set Match = Matches(0)
    
62.             Cell.Value = RegExp.Replace(Cell.Value, "$1$1$2")
    
63.         End If
    
64.     Next
    
65. 
    
66. End Sub

复制代码

ABAB_AB2.zip (525.63 KB, 下载次数: 5)

2021-7-28 23:14 上传

点击文件名下载附件

梦幻的流星

在单元格中循环数据量大的时候不死机就怪了

psxk3535

把要查找的内容换成具体的字符，要替换的字符也换成具体的应该快一些，如果是模糊查找替换，数据量又大，根据快不了

zpy2

附件看不太清楚，能否模拟一下结果，解释一下。

DevilW

对单元格写入4万次？你不能用数组替代吗

jsjcjsjc

梦幻的流星 发表于 2021-7-29 02:51
在单元格中循环数据量大的时候不死机就怪了

求指点啊……大佬

jsjcjsjc

DevilW 发表于 2021-7-29 10:21
对单元格写入4万次？你不能用数组替代吗

比较菜啊…所以才发帖问的呀…()

jsjcjsjc

zpy2 发表于 2021-7-29 09:31
附件看不太清楚，能否模拟一下结果，解释一下。

附件可以直接执行啊,可以试试第5个"确定"
感谢

psxk3535

jsjcjsjc 发表于 2021-7-29 22:36
附件可以直接执行啊,可以试试第5个"确定"
感谢

还是不要试了，必须要有耐心才行，最好把你的要求发出来，让各位老师重新给你写一个