如何用正则找出有且只有3次重复的数字

Windor123

需求1:同样的数字存在3次重复，如果也存在3次以上的重复，此数字找出
例如：0.366---.777+++.5-.9999999//0.8--0.333+0.3333
要找出的数字为777和333，不能从9999999找出999

需求2:同样的数字存在3次重复，但如果也存在3次以上的重复，此数字不能找出
例如：0.366---.777+++.5-.9999999//0.8--0.333+0.3333
要找出的数字777，不能从9999999找出999，也不能找出333

要求，只能使用正则方法直接找出。

ynzsvt

两个程序啊，还限定用正则，不用不可以？

taller

'等待正则高手分享正则直接找出的代码

1. 
   
2. 
   
3. 
   
4. Sub FindThreeRepeatedDigits() ' 正则匹配之后再核查之前和之后的字符
   
5.     Dim regEx As Object
   
6.     Set regEx = CreateObject("VBScript.RegExp")
   
7.     ' 匹配连续3个相同数字
   
8.     regEx.Pattern = "(\d)\1\1"
   
9.     regEx.Global = True
   
10.    
    
11.     Dim s As String
    
12.     ' 示例字符串
    
13.     s = "0.366---.777+++.5-.9999999//0.8--0.333+0.3333"
    
14.    
    
15.     Dim matches As Object, m As Object
    
16.     Set matches = regEx.Execute(s)
    
17.     Dim posStart As Long, posEnd As Long
    
18.     Dim repeatedDigit As String
    
19.     Dim isValid As Boolean
    
20.    
    
21.     ' 对每个匹配，检查是否正好是3个连续相同数字
    
22.     For Each m In matches
    
23.         ' VBA字符串采用1为起始，RegExp的FirstIndex基于0
    
24.         posStart = m.FirstIndex + 1
    
25.         posEnd = posStart + m.Length - 1
    
26.         ' m.SubMatches(0) 就是重复数字（第1个捕获组）
    
27.         repeatedDigit = m.SubMatches(0)
    
28.         isValid = True
    
29.         
    
30.         ' 检查匹配前一个字符（如果存在），判断是否与重复数字相同
    
31.         If posStart > 1 Then
    
32.             If Mid(s, posStart - 1, 1) = repeatedDigit Then
    
33.                 isValid = False
    
34.             End If
    
35.         End If
    
36.         
    
37.         ' 检查匹配后一个字符（如果存在），判断是否与重复数字相同
    
38.         If posEnd < Len(s) Then
    
39.             If Mid(s, posEnd + 1, 1) = repeatedDigit Then
    
40.                 isValid = False
    
41.             End If
    
42.         End If
    
43.         
    
44.         ' 输出结果
    
45.         If isValid Then
    
46.             Debug.Print m.Value
    
47.         End If
    
48.     Next m
    
49. End Sub
    

复制代码

Windor123

谢谢大佬。

Windor123

Sub tttt()
Dim reg As Object, strTxt$, d1 As Object, oKey, k%
Set d1 = CreateObject("scripting.dictionary")
Set reg = CreateObject("vbscript.regexp")
strTxt = "0.366---.777+++.5-.9999999//0.8--0.333+0.3333"
k = 0
With reg
   .Global = True
   .Pattern = "((\d)\2{2})\2*"
   Set mat = .Execute(strTxt)
   If .test(strTxt) Then
      For Each matt In mat
         d1(matt.submatches(0)) = d1(matt.submatches(0)) + 1
         If matt = matt.submatches(0) Then a = a & "," & matt: k = k + 1
      Next matt
   End If
End With
If k = 0 Then MsgBox "符合需求1的连续重复数字不存在.": Exit Sub
Debug.Print Mid(a, 2)  '需求1

For Each oKey In d1.Keys()
   If d1(oKey) > 1 And InStr(a, oKey) > 0 Then
      a = Replace(a, "," & oKey, "")
   End If
Next oKey
If a = "" Then MsgBox "符合需求2的连续重复数字不存在.": Exit Sub
Debug.Print Mid(a, 2)  '需求2

End Sub

Windor123

此问题的进一步需求是:
需求3：用aaa替换符合需求1的连续数字
示例结果：0.366---.aaa+++.5-.9999999//0.8--0.aaa+0.3333

需求4：用bbb替换符合需求2的连续数字
示例结果：0.366---.aaa+++.5-.9999999//0.8--0.333+0.3333

ynzsvt

4个程序已经完成了几个
777.366---.777+++.5-.9999999//0.8--0.333+0.3333的4个输出结果分别是什么。

tcdatongye

wps函数即可：
REGEXP(A1,"(^|\D)(\d)\2{2}(?!\d)",2,"\1aaa")
=REGEXP(A1,"(^|\D)(\d)\2{2}(?!\d)(?!.*?\2{4})",2,"\1bbb")该表达式仅适合多位数在后面情况。

ynzsvt

1. Sub 正则提取三连数()
   
2. Dim St$, St1$, Arr(1 To 4), Reg As Object, Dic As Object
   
3. Dim Mat, Matt, Fg
   
4. Fg = "/"
   
5. St = "777.366---.777+++.5-.9999999//0.8--0.333+0.3333"
   
6. ' 按无匹配先出结果
   
7. Arr(1) = "无"
   
8. Arr(2) = "无"
   
9. Arr(3) = St
   
10. Arr(4) = St
    
11. ' 正则取得连续4个及以上数字的建立字典
    
12. Set Reg = CreateObject("vbscript.regexp")
    
13. Set Dic = CreateObject("Scripting.Dictionary")
    
14. 
    
15. With Reg
    
16.   .Global = True
    
17.   .Pattern = "(\d)\1{3,}"
    
18.   Set Mat = .Execute(St)
    
19.   If .test(St) Then
    
20.    For Each Matt In Mat
    
21.     St1 = Matt.submatches(0)
    
22.     Dic(St1) = ""
    
23.    Next 'matt
    
24.   End If
    
25. End With
    
26. 
    
27. ' 正则取得连续3个数的得到规则1规则3结果
    
28. ' 正则取得连续3个数的得到规则2规则4结果
    
29. With Reg
    
30.   .Global = True
    
31.   .Pattern = "(\d)\1{2,}"
    
32.   Set Mat = .Execute(St)
    
33.   If .test(St) Then
    
34.    For Each Matt In Mat
    
35.     If Matt.Length = 3 Then
    
36.      St1 = Matt.submatches(0)
    
37.      If Dic.Exists(St1) Then
    
38.       Arr(1) = Arr(1) & Fg & Matt
    
39.       Arr(3) = Left(Arr(3), Matt.FirstIndex) & Replace(Arr(3), Matt, "aaa", Matt.FirstIndex + 1, 1)
    
40.      Else
    
41.       Arr(1) = Arr(1) & Fg & Matt
    
42.       Arr(2) = Arr(2) & Fg & Matt
    
43.       Arr(3) = Left(Arr(3), Matt.FirstIndex) & Replace(Arr(3), Matt.Value, "aaa", Matt.FirstIndex + 1, 1)
    
44.       Arr(4) = Left(Arr(4), Matt.FirstIndex) & Replace(Arr(4), Matt.Value, "aaa", Matt.FirstIndex + 1, 1)
    
45.      End If
    
46.     End If
    
47.    Next 'matt
    
48.    Arr(1) = Mid(Arr(1), 3)
    
49.    Arr(2) = Mid(Arr(2), 3)
    
50.   End If
    
51. End With
    
52. 
    
53. [b1:e1] = Arr
    
54. 
    
55. Set Dic = Nothing
    
56. End Sub

复制代码

Windor123

厉害。
手上没有鲜花，否则献上。

如果增加
InStr(Arr(1), Matt) = 0
InStr(Arr(2), Matt) = 0
的判断。
正是所需要的结果。