请问如何提取地址，人名，电话

寿司的骆驼

请问大神们，从一列杂乱无章的信息里，如何提取地址，人名和电话啊，太难了，请见附件。

opel-wong

有规则的话，应该不难吧，
留个记号，晚上有空再看，

zpy2

SELECT regexp2('^.*：(.*?)\b([\x{4e00}-\x{9fa5}]{2,5})\s*(\d{11}|\d{4}[\d-]+)\s*',地址姓名电话,1),regexp2('\b([\x{4e00}-\x{9fa5}]{2,5})\s*(\d{11}|\d{4}[\d-]+)\s*',地址姓名电话,1),regexp2('\b([\x{4e00}-\x{9fa5}]{2,5})\s*(\d{11}|\d{4}[\d-]+)\s*',地址姓名电话,2),* FROM 地址姓名电话明细表

opel-wong

拆分了一下，先看看效果吧，

smiletwo

Sub ss()
  Dim i, j, row, arr, mh
  Dim reg As Object
  On Error Resume Next
  Set reg = CreateObject("vbscript.regexp")
  reg.Global = True
  reg.Pattern = "货发\W\s?(.+?)\s+([一-龢]{2,3})(\s+)?(\d+((\-\d+)+)?)\s?" ‘3可根据姓名最多的字数修改
  row = Cells(Rows.Count, 1).End(3).row
  arr = Range("A1:D" & row)
  For i = 1 To row
     Set mh = reg.Execute(arr(i, 1))
     arr(i, 2) = mh(0).submatches(0)
     arr(i, 3) = mh(0).submatches(1)
     arr(i, 4) = mh(0).submatches(3)
  Next
  Range("A1:D" & row) = arr
End Sub

opel-wong

代码如下，供参考：

opel-wong

smiletwo 发表于 2020-8-25 21:17
Sub ss()
  Dim i, j, row, arr, mh
  Dim reg As Object

5楼，正则的方法好，
这个题，正则才是王道！

smiletwo

opel-wong 发表于 2020-8-25 21:38
5楼，正则的方法好，
这个题，正则才是王道！

学习中，所以表达式比较繁琐

opel-wong

代码如下，供参考：

1. Sub 提取数据()
   
2.     Dim arr, brr, i As Long, mStr$, a$, b$
   
3.     With Sheet2
   
4.         arr = .Range("A1:A" & .Range("A65536").End(3).row).Value
   
5.         ReDim brr(1 To UBound(arr), 1 To 3)
   
6.         For i = 1 To UBound(arr)
   
7.             If InStr(arr(i, 1), "货发") Then
   
8.                 mStr = LTrim(Split(arr(i, 1), "货发：")(1))
   
9.                 If InStr(mStr, "，") Then
   
10.                     a = "，"
    
11.                 ElseIf InStr(mStr, " ") Then
    
12.                     a = " "
    
13.                 Else
    
14.                     a = "  "
    
15.                 End If
    
16.                 If InStr(mStr, "省") And Mid(mStr, InStr(mStr, "省") + 1, 1) = " " Then
    
17.                     b = Split(mStr, "  ")(0)
    
18.                     brr(i, 1) = Split(mStr, "  ")(0)
    
19.                     brr(i, 2) = Mid(brr(i, 1), InStrRev(brr(i, 1), " ") + 1, Len(brr(i, 1)))
    
20.                     brr(i, 3) = Mid(mStr, InStrRev(mStr, " ") + 1, Len(mStr))
    
21.                     brr(i, 1) = Replace(Mid(b, 1, InStrRev(b, " ") - 1), " ", "")
    
22.                 Else
    
23.                     brr(i, 1) = LTrim(Split(mStr, a)(0))
    
24.                     brr(i, 2) = LTrim(Mid(mStr, InStr(mStr, a) + 1, Len(mStr)))
    
25.                     brr(i, 3) = Empty
    
26.                 End If
    
27.             End If
    
28.         Next
    
29.         For i = 1 To UBound(brr)
    
30.             If Left(brr(i, 1), 2) = "地址" Then brr(i, 1) = Mid(brr(i, 1), 3, Len(brr(i, 1)) - 2)
    
31.             If InStr(brr(i, 2), "沧州爱尔眼科医院") Then brr(i, 2) = LTrim(Replace(brr(i, 2), "沧州爱尔眼科医院", ""))
    
32.             mStr = brr(i, 2)
    
33.             If InStr(mStr, " ") Then
    
34.                 brr(i, 2) = LTrim(Mid(mStr, 1, InStr(mStr, " ") - 1))
    
35.                 brr(i, 3) = LTrim(Mid(mStr, InStr(mStr, " ") + 1, Len(mStr)))
    
36.             End If
    
37.             mStr = brr(i, 3)
    
38.             If VBA.IsNumeric(Left(mStr, 1)) Then
    
39.                 If InStr(mStr, " ") Then brr(i, 3) = Mid(mStr, 1, InStr(mStr, " ") - 1)
    
40.             Else
    
41.                 If InStr(mStr, "  ") Then brr(i, 3) = Split(mStr, "  ")(1)
    
42.             End If
    
43.             If brr(i, 2) Like "*[0-9]*" And Len(brr(i, 3)) = 0 Then
    
44.                 mStr = brr(i, 2)
    
45.                 brr(i, 2) = TQ(mStr, 1)
    
46.                 brr(i, 3) = TQ(mStr, 3)
    
47.             End If
    
48.         Next
    
49.         .Range("b:d").ClearContents
    
50.         .Range("b1").Resize(UBound(brr), 3).Value = brr
    
51.     End With
    
52. End Sub
    
53. 
    
54. Function TQ(txt, Optional L = 1)
    
55.     Dim pt, i As Long, t, s
    
56.     pt = Choose(L, "[一-龥]", "[a-zA-Z]", "[0-9]", "[a-z]", "[A-Z]", "[0-9a-zA-Z]")
    
57.     For i = 1 To Len(txt)
    
58.         t = Mid(txt, i, 1)
    
59.         If t Like pt Then s = s & t
    
60.     Next
    
61.     TQ = s
    
62. End Function

复制代码

寿司的骆驼

smiletwo 发表于 2020-8-25 21:17
Sub ss()
  Dim i, j, row, arr, mh
  Dim reg As Object

谢谢帮助，请问如果条件不在A列，在B列或者C列，需要修改那个参数？