zoukankan      html  css  js  c++  java
  • 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, "(1d{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 & "	xt导出手机" & Format(Now, "yyyymmdd-hhmm") & ".txt"
        PhoneContent = Mid(PhoneContent, 2)
        NewTextFile PhoneFilePath, PhoneContent
        
        MailFilePath = Wb.Path & "	xt导出邮箱" & 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
    

      

  • 相关阅读:
    [转载]Nginx 常见应用技术指南
    【转载】Memcached Tip 2:Session同步
    【转载】大规模网站架构实战之体系结构
    【转载】3种Nginx防盗链的方法
    poj2390
    poj2395
    poj2393
    poj2209
    poj2392
    爱我更多,好吗?
  • 原文地址:https://www.cnblogs.com/nextseven/p/9775768.html
Copyright © 2011-2022 走看看