Public Sub GetCellPhone()
Dim CellPhone As String
Dim Arr As Variant
Dim Brr As Variant
Dim n As Long
Dim FolderPath As String
Dim FileName As String
Dim FilePath As String
Dim Zone As String
Dim WholeLine As String
Dim OneLine As String
Dim Phone As Variant
WholeLine = ""
FolderPath = ThisWorkbook.Path & "\"
FileName = "电话号码导出.txt"
FilePath = FolderPath & FileName
Debug.Print FilePath With Sheets("设置")
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range("A2:A" & EndRow)
Brr = Rng.Value
End With With Sheets("原始数据")
EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
For i = 2 To EndRow
For m = LBound(Brr) To UBound(Brr)
If InStr(1, .Cells(i, 1).Value, Brr(m, 1)) > 0 Then
Zone = .Cells(i, 1).Value
Arr = RegGetArray("(1\d{10})", .Cells(i, 2).Text)
CellPhone = Duplication(Arr)
If Len(CellPhone) > 1 Then
.Cells(i, 3).Value = "'" & CellPhone
Phone = Split(CellPhone, ";")
For n = LBound(Phone) To UBound(Phone)
OneLine = Phone(n) & vbCrLf
WholeLine = WholeLine & OneLine
Next n
End If
End If
Next m
Next i
End With
'Debug.Print WholeLine
Open FilePath For Output As #1
Print #1, WholeLine
Close #1
End Sub
Function Duplication(ByVal Arr As Variant) As String
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
For i = LBound(Arr) To UBound(Arr)
Key = CStr(Arr(i))
Dic(Key) = ""
Next i
If Dic.Count > 0 Then
Duplication = Join(Dic.keys, ";")
Else
Duplication = ""
End If
Set Dic = Nothing
End Function
Function RegGetArray(ByVal Pattern As String, ByVal OrgText As String) As String()
Dim Reg As Object, Mh As Object, OneMh As Object
Dim Arr() As String, Index As Long
Dim Elm As String
Set Reg = CreateObject("Vbscript.Regexp")
With Reg
.MultiLine = True
.Global = True
.Ignorecase = False
.Pattern = Pattern
If .test(OrgText) Then
Set Mh = .Execute(OrgText)
Index = 0
ReDim Arr(1 To 1)
For Each OneMh In Mh
Index = Index + 1
ReDim Preserve Arr(1 To Index)
Arr(Index) = OneMh.submatches(0)
Next OneMh
Else
ReDim Arr(1 To 1)
Arr(1) = ""
End If
End With
RegGetArray = Arr
Set Reg = Nothing
Set Mh = Nothing
End Function