20181011xlVba提取邮箱手机号码

Sub TransferData()

    AppSettings
    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer

    On Error GoTo ErrHandler

    Dim dHas As Object
    Dim dNew As Object
    Dim Key As String
    Dim OneKey

    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim oSht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Dim NewWb As Workbook
    Dim NewSht As Worksheet
    Dim EndRow As Long, EndCol As Long
    Dim i As Long, j As Long
    Dim FolderPath As String
    Dim FilePath, FilePaths, sMail, arMail, OneAr
    Dim MailContent, PhoneContent

    MailContent = ""
    PhoneContent = ""

    Set dNew = CreateObject("Scripting.Dictionary")
    Set dHas = CreateObject("Scripting.Dictionary")
    Set Wb = Application.ThisWorkbook
    Set Sht = Wb.Worksheets("邮箱列表")
    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        If EndRow > 1 Then
            Set Rng = .Range("A1").Resize(EndRow, 1)
            Arr = Rng.Value
            For i = LBound(Arr) To UBound(Arr)
                Key = CStr(Arr(i, 1))
                dHas(Key) = ""
            Next i
        End If
    End With

    FolderPath = Wb.Path & "\表格一\"
    FilePaths = FsoGetFiles(FolderPath, "*.xls*")
    If FilePaths(1) = "None" Then GoTo ErrorExit

    For Each FilePath In FilePaths
        Set OpenWb = Application.Workbooks.Open(FilePath)
        Set OpenSht = OpenWb.Worksheets(1)
        With OpenSht
            EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            Set Rng = .Range("A3:J" & EndRow)
            Arr = Rng.Value
            For i = LBound(Arr) To UBound(Arr)
                sMail = Arr(i, 10)
                If Len(sMail) > 0 Then
                    sMail = Left(sMail, Len(sMail) - 1)
                    arMail = Split(sMail, ";")
                    For Each OneAr In arMail
                        'Debug.Print " OneAr>"; OneAr
                        Key = RegGet(OneAr, "(\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*)")
                        If Len(Key) > 0 Then
                              'Debug.Print "Key>"; Key
                              'Debug.Print ">>>>"; Key; " > "; Arr(i, 2); " > "; Arr(i, 1)
                            dNew(Key) = Array(Key, Arr(i, 2), Arr(i, 1))
                            MailContent = MailContent & vbCrLf & Key
                        End If
                    Next OneAr
                End If

                sPhone = Arr(i, 7)
                If Len(sPhone) > 0 Then
                    sPhone = Left(sPhone, Len(sPhone) - 1)
                    arPhone = Split(sPhone, ";")
                    For Each OneAr In arPhone
                        Key = RegGet(OneAr, "(1\d{10})")
                        If Key <> "" Then PhoneContent = PhoneContent & vbCrLf & Key
                    Next OneAr
                End If

                'If i = 10 Then Exit For
            Next i
        End With
        OpenWb.Close False
    Next FilePath

    '对比去重
    For Each OneKey In dHas.keys
        If dNew.exits(OneKey) Then dNew.Remove (OneKey)
    Next OneKey

    Set oSht = Wb.Worksheets("_人地址薄")
    FilePath = Wb.Path & "\表格二\导出文件" & Format(Now, "yyyymmdd-hhmm") & ".xlsx"

    Set NewWb = Application.Workbooks.Add
    NewWb.SaveAs FilePath

    oSht.Copy before:=NewWb.Worksheets(1)
    Set NewSht = NewWb.Worksheets("_人地址薄")
    With NewSht
        Set Rng = .Range("A2")
        Set Rng = Rng.Resize(dNew.Count, 3)
        Rng.Value = Application.Rept(dNew.Items, 1)
    End With

    On Error Resume Next
    NewWb.Worksheets(2).Delete
    On Error GoTo 0

    NewWb.Save
    NewWb.Close False

    PhoneFilePath = Wb.Path & "\txt\导出手机" & Format(Now, "yyyymmdd-hhmm") & ".txt"
    PhoneContent = Mid(PhoneContent, 2)
    NewTextFile PhoneFilePath, PhoneContent

    MailFilePath = Wb.Path & "\txt\导出邮箱" & Format(Now, "yyyymmdd-hhmm") & ".txt"
    MailContent = Mid(MailContent, 2)
    NewTextFile MailFilePath, MailContent

    With Sht
        Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        Set Rng = Rng.Resize(dNew.Count, 3)
        Rng.Value = Application.Rept(dNew.Items, 1)
        .Range("B:C").ClearContents
    End With

    UsedTime = VBA.Timer - StartTime
    Debug.Print "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")
    'MsgBox "UsedTime ：" & Format(UsedTime, "#0.0000 Seconds")

ErrorExit:

    Set dHas = Nothing
    Set dNew = Nothing
    Set Wb = Nothing
    Set NewWb = Nothing
    Set OpenWb = Nothing
    Set Sht = Nothing
    Set oSht = Nothing
    Set OpenSht = Nothing
    Set NewSht = Nothing

    AppSettings False
    Exit Sub
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！", vbCritical, "AuthorQQ 84857038"
        Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If

End Sub
Public Sub AppSettings(Optional IsStart As Boolean = True)
    Application.ScreenUpdating = IIf(IsStart, False, True)
    Application.DisplayAlerts = IIf(IsStart, False, True)
    Application.Calculation = IIf(IsStart, xlCalculationManual, xlCalculationAutomatic)
    Application.StatusBar = IIf(IsStart, ">>>>>>>>Macro Is Running>>>>>>>>", False)
End Sub

Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()
    Dim Arr() As String
    Dim FSO As Object
    Dim ThisFolder As Object
    Dim OneFile As Object
    ReDim Arr(1 To 1)
    Arr(1) = "None"
    Dim Index As Long
    Index = 0
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error GoTo ErrorExit
    Set ThisFolder = FSO.getfolder(FolderPath)
    If Err.Number <> 0 Then Exit Function
    For Each OneFile In ThisFolder.Files
        If OneFile.Name Like Pattern Then
            If Len(ComplementPattern) > 0 Then
                If Not OneFile.Name Like ComplementPattern Then
                    Index = Index + 1
                    ReDim Preserve Arr(1 To Index)
                    Arr(Index) = OneFile.Path
                End If
            Else
                Index = Index + 1
                ReDim Preserve Arr(1 To Index)
                Arr(Index) = OneFile.Path
            End If
        End If
    Next OneFile
ErrorExit:
    FsoGetFiles = Arr
    Erase Arr
    Set FSO = Nothing
    Set ThisFolder = Nothing
    Set OneFile = Nothing
End Function
Public Function RegGet(ByVal OrgText As String, ByVal Pattern As String) As String
    Dim Regex As Object
    Dim Mh As Object
    Set Regex = CreateObject("VBScript.RegExp")
    With Regex
        .Global = True
        .Pattern = Pattern
    End With
    If Regex.test(OrgText) Then
        Set Mh = Regex.Execute(OrgText)
        RegGet = Mh.Item(0).submatches(0)
    Else
        RegGet = ""
    End If
    Set Regex = Nothing
End Function
Sub NewTextFile(ByVal FilePath As String, ByVal FileContent As String)
    Open FilePath For Output As #1
    Print #1, FileContent
    Close #1
End Sub