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