20170822xlVBA ExportCellPhone

最新推荐文章于 2018-10-13 20:50:00 发布

转载最新推荐文章于 2018-10-13 20:50:00 发布 · 123 阅读

0 ·

CC 4.0 BY-SA版权

原文链接：http://www.cnblogs.com/nextseven/p/7412259.html

本文介绍了一种使用VBA从Excel工作表中批量提取手机号的方法。通过定义一系列函数，包括GetCellPhone和辅助函数，实现了从指定列读取数据并应用正则表达式匹配手机号的功能。此外，该程序还能够去除重复的手机号，并将结果输出到文件。

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

转载于:https://www.cnblogs.com/nextseven/p/7412259.html