20170822xlVBA ExportCellPhone

Posted 2020-10-03 Excel VBA 小天地

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