拆分地址和电话号码

高度保密

提取地址电话号码.rar (2.87 KB, 下载次数: 31)

2024-3-20 20:49 上传

点击文件名下载附件

求助各位大师，麻烦帮忙从地址电话中，把地址和电话分别提取出来。谢谢！

shiruiqiang

正则式，先提取电话，再替换掉正则式(电话)

ykcbf1100

用正则拆分。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.3.20
   
2.     Set reg = CreateObject("VBScript.Regexp")
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         arr = .[a1].Resize(r, 3)
   
6.         .UsedRange.Offset(1, 1) = ""
   
7.         With reg
   
8.             .Pattern = "^(.*?)\s*(\d{3,4}-\d{7,8}|\d+)$"
   
9.             For i = 2 To UBound(arr)
   
10.                 s = Replace(arr(i, 1), " ", "")
    
11.                 If .test(s) Then
    
12.                     Set mh = .Execute(s)
    
13.                     For Each ma In mh
    
14.                         arr(i, 2) = Trim(ma.submatches(0))
    
15.                         arr(i, 3) = Trim(ma.submatches(1))
    
16.                     Next
    
17.                 End If
    
18.             Next
    
19.         End With
    
20.        .[a1].Resize(r, 3) = arr
    
21.     End With
    
22. End Sub
    

复制代码

liulang0808

Sub test()
    r = Cells(Rows.Count, 1).End(3).Row
    arr = [a1].Resize(r, 2)
    With CreateObject("vbscript.regexp")
        .Pattern = "\d+[0-9\s-]+$"
        For j = 2 To UBound(arr)
            If .test(arr(j, 1)) Then
                arr(j, 2) = .Execute(arr(j, 1))(0)
                arr(j, 1) = .Replace(arr(j, 1), "")
            Else
                arr(j, 2) = ""
            End If
        Next j
    End With
    [f1].Resize(r, 2) = arr
End Sub

liulang0808

附件内容供参考

高度保密

shiruiqiang 发表于 2024-3-20 20:56
正则式，先提取电话，再替换掉正则式(电话)

谢谢！对正则是懵的，所以特来求助

高度保密

ykcbf1100 发表于 2024-3-20 21:08
用正则拆分。。。

结果正确，谢谢老师！

高度保密

liulang0808 发表于 2024-3-20 21:17
附件内容供参考

多谢版主！

cnmlgb9998

根本用不上 VBA 和 正则，很简单的操作PQ ！！！！！！！！！