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