VBA研究重复邮件号码筛重（文件间）

Posted 2022-11-24 宋哥

作者：iamlaosong

最近业务部门提出一个需求，就是筛查市县分公司上报的邮件号码（比如破损邮件）是否已经报过？具体是什么邮件工具并不关心，只要实现邮件号码筛查就可以了。

功能并不复杂，只是将一个文件中的邮件号码和已有的多个文件中邮件号码比较，记录下比较结果就可以了。上报的邮件数据放在当前文件夹下（和工具文件在一起），原有的数据文件放在一个文件夹中多个子文件夹中。比较方法是取一个上报文件中数据和所有原有的数据进行对比，在重复邮件号码后面记录下重复号码在原有数据中的位置信息。每个上报文件对比结束后，如果有重复，则生成一个存有位置信息的新文件，否则，就不生成。

要实现和所有原有数据文件的对比，就需要遍历这个原有数据文件夹下所有文件，文件夹内容如下图所示：

遍历所有文件，将文件名放到一个数组中，以便后面一一打开比较。方法是先找出所有文件夹，再找出文件夹下所有文件，代码只针对这种文件夹结构，具体代码如下：

    '原始数据目录
    DirNo = 0
    sFile = Dir(ThisWorkbook.Path & "\\" & pmDir & "\\*", vbDirectory)
    Do While sFile <> ""
        DirNo = DirNo + 1
        arrDir(DirNo) = sFile
        sFile = Dir
    Loop
    
    '找出所有数据文件
    FileNo = 0
    For i = 3 To DirNo
        '查出此文件夹下所有.xls文件（含.xlsx）
        sFile = Dir(ThisWorkbook.Path & "\\" & pmDir & "\\" & arrDir(i) & "\\*.xls")
        Do While sFile <> ""
            FileNo = FileNo + 1
            arrFile(FileNo) = arrDir(i) & "\\" & sFile
            sFile = Dir
        Loop
    Next i
    If FileNo = 0 Then
        MsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"
        Exit Sub
    End If

为了使工具更具通用性，采取一些参数可以设置，工具界面和代码如下：

 

Sub get_data()
    
    Dim i, k, k1, k2, MailNo, PmNo, DirNo, FileNo As Integer
    Dim Mail As String, arrDir(20) As String, arrFile(200) As String, sFile As String
    Dim arrData1(), arrData2(), pmDir, pmName, pmRow1, pmCol1, pmCol2
    Dim MaxRow1 As Long, MaxRow2 As Long
 
 
    'On Error GoTo Err
    If Cells(2, 2) = "Y" Or Cells(2, 2) = "y" Then                              '导出出库文件
        Application.ScreenUpdating = True
    Else
        Application.ScreenUpdating = False
    End If
    
    pmDir = Cells(2, 2)
    lineno = [B65536].End(xlUp).Row           '行数
    
    '读取参数
    pmName = Cells(2, 7)
    pmRow1 = Cells(3, 7)
    pmCol1 = Cells(4, 7)
    
    '原始数据目录
    DirNo = 0
    sFile = Dir(ThisWorkbook.Path & "\\" & pmDir & "\\*", vbDirectory)
    Do While sFile <> ""
        DirNo = DirNo + 1
        arrDir(DirNo) = sFile
        sFile = Dir
    Loop
    
    '找出所有数据文件
    FileNo = 0
    For i = 3 To DirNo
        '查出此文件夹下所有.xls文件（含.xlsx）
        sFile = Dir(ThisWorkbook.Path & "\\" & pmDir & "\\" & arrDir(i) & "\\*.xls")
        Do While sFile <> ""
            FileNo = FileNo + 1
            arrFile(FileNo) = arrDir(i) & "\\" & sFile
            sFile = Dir
        Loop
    Next i
    If FileNo = 0 Then
        MsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"
        Exit Sub
    End If
    
    '开始数据处理
    tim1 = Now()
    For unit_num = 5 To lineno                 '文件循环
    
        MailNo = 0
        datfile = Cells(unit_num, 2)                              '文件名称
        datFullName = ThisWorkbook.Path & "\\" & datfile
        If Dir(datFullName, vbNormal) <> vbNullString Then
            Workbooks.Open Filename:=datFullName        '打开数据文件
            Sheets(pmName).Select
            MaxRow1 = Range(pmCol1 & pmRow1).End(xlDown).Row     '行数
            'MaxRow = ActiveSheet.UsedRange.Rows.Count     '行数
            If MaxRow1 >= pmRow1 Then
                pmCol2 = Cells(pmRow1 - 1, Columns.Count).End(xlToLeft).Column + 1
                arrData1 = Range(Cells(1, pmCol1), Cells(MaxRow1, pmCol1).Offset(0, 2)).Value
            End If
            For k1 = 1 To MaxRow1
                arrData1(k1, 2) = ""
                arrData1(k1, 3) = ""
            Next k1
            'ActiveWindow.Close
        Else
            MsgBox "数据文件不存在！", vbOKOnly, "iamlaosong"
            Exit Sub
        End If
        
        '开始筛查：每一个上报文件对比所有原始数据文件
        For k = 1 To FileNo
            Workbooks.Open Filename:=ThisWorkbook.Path & "\\" & pmDir & "\\" & arrFile(k)         '打开数据文件
            MaxRow2 = Range("D1").End(xlDown).Row       '行数（数据从第2行开始）
            If MaxRow2 >= 2 Then
                arrData2 = Range(Cells(1, "D"), Cells(MaxRow2, "D")).Value
            End If
            ActiveWindow.Close
            For k1 = pmRow1 To MaxRow1
                Mail = CStr(arrData1(k1, 1))
                For k2 = 2 To MaxRow2
                    If Mail = CStr(arrData2(k2, 1)) Then
                       MailNo = MailNo + 1
                       arrData1(k1, 2) = arrData1(k1, 2) & "#" & k2
                       arrData1(k1, 3) = arrData1(k1, 3) & "#" & arrFile(k)
                    End If
                Next k2
            Next k1
            Application.StatusBar = datfile & "完成：" & Round(k * 100 / FileNo, 2) & "%"
            DoEvents
        Next k
        Windows(datfile).Activate
        If MailNo > 0 Then
            For k1 = pmRow1 To MaxRow1
                If arrData1(k1, 2) <> "" Then
                    Cells(k1, pmCol2) = arrData1(k1, 2)
                    Cells(k1, pmCol2 + 1) = arrData1(k1, 3)
                End If
            Next k1
            expfile = ThisWorkbook.Path & "\\New" & datfile
            ActiveWorkbook.SaveAs Filename:=expfile
        End If
        
        ActiveWindow.Close
        
        Cells(unit_num, 3) = MailNo
    Next unit_num
    Application.StatusBar = "就绪"
    
    msg = MsgBox("处理完毕，用时" & CInt((Now() - tim1) * 86400) & "秒！", vbOKOnly, "ＡＨＥＭＳ：iamlaosong")
End Sub