将姓名和电话号码拆分

cjc209

我发一个VBA 灵活性代码  可以作为工具使用

1. Sub 正则替换()
   
2.    
   
3.   
   
4.     On Error Resume Next
   
5.     Set regx = CreateObject("vbscript.regexp")
   
6. 1:
   
7.     Set sjq = Application.InputBox(prompt:="请选择：查找区域", Type:=8)
   
8.     If sjq Is Nothing Then GoTo ff1
   
9.     sjqzhs = sjq.Rows.Count
   
10.     sjqqsl = sjq.Column
    
11.     sjqqsh = sjq.Row
    
12.     Set jgq = Application.InputBox(prompt:="请选择：结果摆放起始位", Type:=8)
    
13.     If jgq Is Nothing Then GoTo ff1
    
14.     Application.ScreenUpdating = False
    
15.     jgqqsh = jgq.Row
    
16.     jgql = jgq.Column
    
17.     arr = sjq
    
18.     With regx
    
19.         .Global = True '默认为 false  只查找第一个  True则全部查找
    
20.         bds = Application.InputBox(prompt:="请输入：正则表达式")
    
21.         .Pattern = bds 'Pattern 是属性 正则表达式的内容
    
22.         bb = MsgBox("是全部替换还是保留 是为替换 否为保留", vbYesNo)
    
23.         If bb = 7 Then GoTo 11
    
24.         th = Application.InputBox(prompt:="替换为：什么")
    
25.         zcljzf = Application.InputBox(prompt:="请输入最初连接字符：什么")
    
26.         jwljzf = Application.InputBox(prompt:="请输入最末连接字符：什么")
    
27.         If sjqzhs > 1 Then GoTo 2
    
28.         Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
    
29.         Cells(jgqqsh + n, jgql) = zcljzf & .Replace(arr, th)
    
30.         GoTo ff
    
31. 2:
    
32.         For Each Rng In arr
    
33.             Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
    
34.             Cells(jgqqsh + n, jgql) = zcljzf & .Replace(Rng, th) & jwljzf 'Replace为一种方法 此种方法为替换
    
35.             If Cells(jgqqsh + n, jgql) = zcljzf & jwljzf Then Cells(jgqqsh + n, jgql) = ""
    
36.             If zcljzf & Cells(sjqqsh + n, sjqqsl) & jwljzf = Cells(jgqqsh + n, jgql) Then Cells(jgqqsh + n, jgql).NumberFormatLocal = "@": Cells(jgqqsh + n, jgql) = Cells(sjqqsh + n, sjqqsl)
    
37.             n = n + 1
    
38.         Next
    
39.         GoTo ff
    
40. 11:
    
41.         bbb = MsgBox("是保留全部还是一个 是为全部 否为一个", vbYesNo)
    
42.         If bbb = 7 Then GoTo 12
    
43.         If sjqzhs > 1 Then GoTo 3
    
44.         fgf = Application.InputBox(prompt:="请输入：分隔符")
    
45.         Set matc = .Execute(arr)
    
46.         sl = matc.Count
    
47.         For Each mm In matc
    
48.             kk = kk + 1
    
49.             If kk = sl Then GoTo 15
    
50.             Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
    
51.             Cells(jgqqsh + n, jgql) = mm2 & mm & fgf
    
52.             mm2 = mm2 & mm & fgf
    
53.             GoTo 17
    
54. 15:
    
55.             Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
    
56.             Cells(jgqqsh + n, jgql) = mm2 & mm
    
57. 17:
    
58.         Next mm
    
59.         GoTo ff
    
60. 3:
    
61.         fgf = Application.InputBox(prompt:="请输入：分隔符")
    
62.         For Each m1 In arr
    
63.             Set k = regx.Execute(m1) 'Execute方法：返回匹配成功的结果，是一个对象
    
64.             js = k.Count
    
65.             For Each m In k
    
66.                 xhcs = xhcs + 1
    
67.                 If js = 1 Then GoTo 33
    
68.                 If js > 1 And xhcs = 1 Then GoTo 33
    
69.                 If xhcs = js Then GoTo 35
    
70.                 Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
    
71.                 Cells(jgqqsh + n, jgql) = m2 & m & fgf
    
72.                 m2 = m2 & m & fgf
    
73.                 GoTo 34
    
74. 33:
    
75.                 Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
    
76.                 Cells(jgqqsh + n, jgql) = m
    
77.                 m2 = m & fgf
    
78.                 GoTo 34
    
79. 35:
    
80.                 Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
    
81.                 Cells(jgqqsh + n, jgql) = m2 & m
    
82. 34:
    
83.             Next
    
84.             m2 = ""
    
85.             xhcs = 0
    
86.             n = n + 1
    
87.         Next
    
88.         GoTo ff
    
89. 12:
    
90.         If sjqzhs > 1 Then GoTo 4
    
91.         fgf = Application.InputBox(prompt:="请输入：分隔符")
    
92.         Set matc = .Execute(arr)
    
93.         sl = matc.Count
    
94.         For Each mm In matc
    
95.             kk = kk + 1
    
96.             If kk = sl Then GoTo 5
    
97.             Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
    
98.             Cells(jgqqsh + n, jgql) = mm2 & mm & fgf
    
99.             mm2 = mm2 & mm & fgf
    
100.             GoTo 7
     
101. 5:
     
102.            Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
     
103.             Cells(jgqqsh + n, jgql) = mm2 & mm
     
104. 7:
     
105.         Next mm
     
106.     End With
     
107.     GoTo ff
     
108. 4:
     
109.     For Each m1 In arr
     
110.         Set k = regx.Execute(m1)
     
111.         For Each m In k
     
112.             ii = ii + 1
     
113.             If ii > 1 Then GoTo 36
     
114.             Cells(jgqqsh + n, jgql).NumberFormatLocal = "@"
     
115.             Cells(jgqqsh + n, jgql) = m
     
116.         Next
     
117. 36:
     
118.         ii = 0
     
119.         n = n + 1
     
120.     Next
     
121.    
     
122. ff:
     
123.     n = 0
     
124.      Application.ScreenUpdating = True
     
125.     aa = MsgBox("是否还需继续处理", vbYesNo)
     
126.     If aa = 6 Then GoTo 1
     
127. ff1:
     
128.   Application.ScreenUpdating = True
     
129. End Sub
     

复制代码

jd23qq

cjc209 发表于 2018-8-5 13:09
我发一个VBA 灵活性代码  可以作为工具使用

功能好强大，但是正则，VB不会写

cjc209

jd23qq 发表于 2018-8-7 12:02
功能好强大，但是正则，VB不会写

这个 只要你知道匹配代码就可以使用了