【VBA研究】重复邮件号码筛重（文件间）
作者：iamlaosong
最近业务部门提出一个需求，就是筛查市县分公司上报的邮件号码（比如破损邮件）是否已经报过？具体是什么邮件工具并不关心，只要实现邮件号码筛查就可以了。
功能并不复杂，只是将一个文件中的邮件号码和已有的多个文件中邮件号码比较，记录下比较结果就可以了。上报的邮件数据放在当前文件夹下（和工具文件在一起），原有的数据文件放在一个文件夹中多个子文件夹中。比较方法是取一个上报文件中数据和所有原有的数据进行对比，在重复邮件号码后面记录下重复号码在原有数据中的位置信息。每个上报文件对比结束后，如果有重复，则生成一个存有位置信息的新文件，否则，就不生成。
要实现和所有原有数据文件的对比，就需要遍历这个原有数据文件夹下所有文件，文件夹内容如下图所示：
遍历所有文件，将文件名放到一个数组中，以便后面一一打开比较。方法是先找出所有文件夹，再找出文件夹下所有文件，代码只针对这种文件夹结构，具体代码如下：
'原始数据目录DirNo = 0sFile = Dir(ThisWorkbook.Path & "\" & pmDir & "\*", vbDirectory)Do While sFile <> ""DirNo = DirNo + 1arrDir(DirNo) = sFilesFile = DirLoop'找出所有数据文件FileNo = 0For i = 3 To DirNo'查出此文件夹下所有.xls文件（含.xlsx）sFile = Dir(ThisWorkbook.Path & "\" & pmDir & "\" & arrDir(i) & "\*.xls")Do While sFile <> ""FileNo = FileNo + 1arrFile(FileNo) = arrDir(i) & "\" & sFilesFile = DirLoopNext iIf FileNo = 0 ThenMsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"Exit SubEnd If为了使工具更具通用性，采取一些参数可以设置，工具界面和代码如下：
Sub get_data()Dim i, k, k1, k2, MailNo, PmNo, DirNo, FileNo As IntegerDim Mail As String, arrDir(20) As String, arrFile(200) As String, sFile As StringDim arrData1(), arrData2(), pmDir, pmName, pmRow1, pmCol1, pmCol2Dim MaxRow1 As Long, MaxRow2 As Long'On Error GoTo ErrIf Cells(2, 2) = "Y" Or Cells(2, 2) = "y" Then '导出出库文件Application.ScreenUpdating = TrueElseApplication.ScreenUpdating = FalseEnd IfpmDir = Cells(2, 2)lineno = [B65536].End(xlUp).Row '行数'读取参数pmName = Cells(2, 7)pmRow1 = Cells(3, 7)pmCol1 = Cells(4, 7)'原始数据目录DirNo = 0sFile = Dir(ThisWorkbook.Path & "\" & pmDir & "\*", vbDirectory)Do While sFile <> ""DirNo = DirNo + 1arrDir(DirNo) = sFilesFile = DirLoop'找出所有数据文件FileNo = 0For i = 3 To DirNo'查出此文件夹下所有.xls文件（含.xlsx）sFile = Dir(ThisWorkbook.Path & "\" & pmDir & "\" & arrDir(i) & "\*.xls")Do While sFile <> ""FileNo = FileNo + 1arrFile(FileNo) = arrDir(i) & "\" & sFilesFile = DirLoopNext iIf FileNo = 0 ThenMsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"Exit SubEnd If'开始数据处理tim1 = Now()For unit_num = 5 To lineno '文件循环MailNo = 0datfile = Cells(unit_num, 2) '文件名称datFullName = ThisWorkbook.Path & "\" & datfileIf Dir(datFullName, vbNormal) <> vbNullString ThenWorkbooks.Open Filename:=datFullName '打开数据文件Sheets(pmName).SelectMaxRow1 = Range(pmCol1 & pmRow1).End(xlDown).Row '行数'MaxRow = ActiveSheet.UsedRange.Rows.Count '行数If MaxRow1 >= pmRow1 ThenpmCol2 = Cells(pmRow1 - 1, Columns.Count).End(xlToLeft).Column + 1arrData1 = Range(Cells(1, pmCol1), Cells(MaxRow1, pmCol1).Offset(0, 2)).ValueEnd IfFor k1 = 1 To MaxRow1arrData1(k1, 2) = ""arrData1(k1, 3) = ""Next k1'ActiveWindow.CloseElseMsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"Exit SubEnd If'开始筛查：每一个上报文件对比所有原始数据文件For k = 1 To FileNoWorkbooks.Open Filename:=ThisWorkbook.Path & "\" & pmDir & "\" & arrFile(k) '打开数据文件MaxRow2 = Range("D1").End(xlDown).Row '行数（数据从第2行开始）If MaxRow2 >= 2 ThenarrData2 = Range(Cells(1, "D"), Cells(MaxRow2, "D")).ValueEnd IfActiveWindow.CloseFor k1 = pmRow1 To MaxRow1Mail = CStr(arrData1(k1, 1))For k2 = 2 To MaxRow2If Mail = CStr(arrData2(k2, 1)) ThenMailNo = MailNo + 1arrData1(k1, 2) = arrData1(k1, 2) & "#" & k2arrData1(k1, 3) = arrData1(k1, 3) & "#" & arrFile(k)End IfNext k2Next k1Application.StatusBar = datfile & "完成：" & Round(k * 100 / FileNo, 2) & "%"DoEventsNext kWindows(datfile).ActivateIf MailNo > 0 ThenFor k1 = pmRow1 To MaxRow1If arrData1(k1, 2) <> "" ThenCells(k1, pmCol2) = arrData1(k1, 2)Cells(k1, pmCol2 + 1) = arrData1(k1, 3)End IfNext k1expfile = ThisWorkbook.Path & "\New" & datfileActiveWorkbook.SaveAs Filename:=expfileEnd IfActiveWindow.CloseCells(unit_num, 3) = MailNoNext unit_numApplication.StatusBar = "就绪"msg = MsgBox("处理完毕，用时" & CInt((Now() - tim1) * 86400) & "秒！", vbOKOnly, "ＡＨＥＭＳ：iamlaosong")
End Sub本文来自互联网用户投稿，文章观点仅代表作者本人，不代表本站立场，不承担相关法律责任。如若转载，请注明出处。 如若内容造成侵权/违法违规/事实不符，请点击【内容举报】进行投诉反馈！