[已解决]提取手机号？

紫晨

试试这个   ＝LEFT（A2，11）

紫晨

这个只能提取第一个手机号
如果有两个以上的就不知道了
你的格式好像不统一

lyf7276

有的中间还有分隔符号，有的又没有。真是为了做事就建个辅助列吧。

hwc2ycy

1. Sub GetMobileNumber()
   
2.     Dim lLastRow As Long, i As Long
   
3.     Dim arr, arr2()
   
4.     Dim strTemp As String
   
5.     lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
   
6.    
   
7.    
   
8.     arr = Range("b1:c" & lLastRow)
   
9.     ReDim arr2(1 To UBound(arr), 1 To 1)
   
10.    
    
11.    
    
12.     Dim reg As Object, arrtemp
    
13.     Set reg = CreateObject("VBScript.regExp")
    
14.     With reg
    
15.         .Global = True
    
16.         .Pattern = "1[853]\d{9}"
    
17.         For i = LBound(arr) + 1 To UBound(arr)
    
18.             strTemp = Replace(arr(i, 1), " ", "")
    
19.             If .test(strTemp) Then
    
20.                 'arrtemp = .Execute(strTemp)
    
21.                 arr2(i, 1) = .Execute(strTemp)(0)
    
22.             End If
    
23.    
    
24.         Next
    
25.     End With
    
26.     Set reg = Nothing
    
27.     arr2(1, 1) = "手机号"
    
28.     Range("e1").Resize(UBound(arr)) = arr2
    
29.     MsgBox "号码提取完成"
    
30. End Sub

复制代码

hwc2ycy

提取单元格中所有手机号码。

1. Sub GetMobileNumber()
   
2.     Dim lLastRow As Long, i As Long, j As Byte
   
3.     Dim arr, arr2()
   
4.     Dim strTemp As String
   
5.     lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
   
6. 
   
7. 
   
8.     arr = Range("b1:c" & lLastRow)
   
9.     ReDim arr2(1 To UBound(arr), 1 To 1)
   
10. 
    
11. 
    
12.     Dim reg As Object, arrTemp
    
13.     Set reg = CreateObject("VBScript.regExp")
    
14.     With reg
    
15.         .Global = True
    
16.         .Pattern = "1[853]\d{9}"
    
17.         For i = LBound(arr) + 1 To UBound(arr)
    
18.             strTemp = Replace(arr(i, 1), " ", "")
    
19.             If .test(strTemp) Then
    
20.                 Set arrTemp = .Execute(strTemp)
    
21.                 If arrTemp.Count > 1 Then
    
22.                     For j = 0 To arrTemp.Count - 1
    
23.                         arr2(i, 1) = arr2(i, 1) & arrTemp(j) & vbCrLf
    
24.                     Next
    
25.                 Else
    
26.                     arr2(i, 1) = arrTemp(0)
    
27.                 End If
    
28.             End If
    
29. 
    
30.         Next
    
31.     End With
    
32.     Set reg = Nothing
    
33.     arr2(1, 1) = "手机号"
    
34.     Range("e1").Resize(UBound(arr)) = arr2
    
35.     MsgBox "号码提取完成"
    
36. End Sub

复制代码

笨笨四

=MID(B2,FIND("A1","A"&SUBSTITUTE(B2,CHAR(10),"A")&"A1"),11)
试试这个。我测试没什么问题。

当然，如果有两个手机号的，这个只有提取一个。如果要提取这两个的话，公式要修改。

hwc2ycy

1. Sub GetMobileNumber1()
   
2. '---------------------------------------------------------------------------------------
   
3. ' Procedure : GetMobileNumber1
   
4. ' Author    : hwc2ycy
   
5. ' Date      : 2013/3/15
   
6. ' Purpose   : 利用正则实现提取所有的手机号码
   
7. '---------------------------------------------------------------------------------------
   
8. '
   
9.     Dim lLastRow As Long, i As Long, j As Byte
   
10.     Dim arr, arr2()
    
11.     Dim strTemp As String
    
12.     Dim reg As Object, arrTemp
    
13. 
    
14.     lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
    
15.     arr = Range("b1:c" & lLastRow)
    
16. 
    
17.     ReDim arr2(1 To UBound(arr), 1 To 1)
    
18. 
    
19.     Set reg = CreateObject("VBScript.regExp")
    
20.     With reg
    
21.         .Global = True
    
22.         .Pattern = "1[853]\d{9}"
    
23. 
    
24.         For i = LBound(arr) + 1 To UBound(arr)
    
25.             strTemp = Replace(arr(i, 1), " ", "")
    
26.             If .test(strTemp) Then
    
27.                 Set arrTemp = .Execute(strTemp)
    
28.                 strTemp = ""
    
29.                 For j = 0 To arrTemp.Count - 1
    
30.                     strTemp = strTemp & arrTemp(j) & vbCrLf
    
31.                 Next
    
32.                 arr2(i, 1) = Left(strTemp, Len(strTemp) - 1)
    
33.             End If
    
34.         Next
    
35.     End With
    
36. 
    
37.     Set reg = Nothing
    
38. 
    
39.     arr2(1, 1) = "手机号"
    
40. 
    
41.     Application.ScreenUpdating = False
    
42.     Range("e1").Resize(UBound(arr)) = arr2
    
43.     MsgBox "号码提取完成"
    
44.     Application.ScreenUpdating = True
    
45. End Sub
    
46. 
    
47. Sub GetMobileNumber2()
    
48. '---------------------------------------------------------------------------------------
    
49. ' Procedure : GetMobileNumber2
    
50. ' Author    : hwc2ycy
    
51. ' Date      : 2013/3/15
    
52. ' Purpose   : 利用正则实现提取第一个手机号码
    
53. '---------------------------------------------------------------------------------------
    
54. '
    
55.     Dim lLastRow As Long, i As Long, j As Byte
    
56.     Dim arr, arr2()
    
57.     Dim strTemp As String
    
58.     Dim reg As Object, arrTemp
    
59. 
    
60.     lLastRow = Cells(Rows.Count, 2).End(xlUp).Row
    
61.     arr = Range("b1:c" & lLastRow)
    
62. 
    
63.     ReDim arr2(1 To UBound(arr), 1 To 1)
    
64. 
    
65.     Set reg = CreateObject("VBScript.regExp")
    
66.     With reg
    
67.         .Global = True
    
68.         .Pattern = "1[853]\d{9}"
    
69. 
    
70.         For i = LBound(arr) + 1 To UBound(arr)
    
71.             strTemp = Replace(arr(i, 1), " ", "")
    
72.             If .test(strTemp) Then
    
73.                 arr2(i, 1) = .Execute(strTemp)(0)
    
74.             End If
    
75.         Next
    
76.     End With
    
77. 
    
78.     Set reg = Nothing
    
79. 
    
80.     arr2(1, 1) = "手机号"
    
81. 
    
82.     Application.ScreenUpdating = False
    
83.     Range("e1").Resize(UBound(arr)) = arr2
    
84.     MsgBox "号码提取完成"
    
85.     Application.ScreenUpdating = True
    
86. End Sub
    

复制代码

hwc2ycy

1.rar (229.46 KB, 下载次数: 16)

2013-3-15 13:50 上传

点击文件名下载附件

笨笨四

MID(SUBSTITUTE(B2," ",""),FIND("A1","A"&SUBSTITUTE(TRIM(SUBSTITUTE(B2," ","")),CHAR(10),"A")&"A1"),11)
改一下。。

cjainwei

蝶·舞 发表于 2013-3-15 11:54
两次分列，然后判断位数进行提取
实际工作嘛，不一定非要一条公式做到死，能出结果就是好方法

妹纸这方法好。求私下教一下