【VBA研究】如何筛选出重复的邮件号码

作者：iamlaosong

客服人员发现地市分公司上报的理赔邮件有重复现象，但人工检查重复非常麻烦，因为这些号码不在一个工作表中。为此我做了一个小工具，可以一键列出Excel文件中所有工作表中重复的号码。有了这个工具，不仅可以筛选重复邮件号码，也可以用于筛选其他重复的东西，比如姓名、身份证号码等等。

1、工具界面

为了提高工具的适应能力，有些参数可以让用户自己设置的，比如文件名、筛选重复的列、数据起始行、附加信息等，界面如下，其中的工作表名称是用日期命名的：

2、功能实现

功能比较简单，无非是循环比较。读取需要比较的号码列及附加列信息，然后就是比较了。取一个号码，首先比较本表有没有重复，然后再读取其他表号码列比较，发现有重复的，记录下号码和附加信息，重复信息。考虑4个重复已经够了，所以表中最多可以记录4个重复信息，如果超过4个，则标注一个“*”号，不再记录。

还有一个问题要注意，数字类的号码可以是数字格式，也可以是文本格式，如果格式不同，即便号码相同也是不等的，如果不注意，可能会漏掉重复号码。安全的解决办法是比较时，转换为文本格式。

如果有需要，还可以在此基础上增加其他功能，比如删除重复号码，给重复号码单元格加上标志等等。如果是删除号码，有一个技巧，就是从后面向前面删除，这样删除的号码不会影响前面号码的定位。

代码如下：

'筛重
Sub get_rep()
    Dim MaxRow, MaxRow1, MaxRow2 As Long
    Dim i, j, k1, k2, DataNo1, DataNo2, RepNo, rr, cc, stNum As Integer
    Dim Mail, colMail, colFee, rowFirst, DatFile As String
    Dim arrAdd1(), arrAdd2(), arrData1(), arrData2(), RepData(1000, 14)

    colpm = 17
    DatFile = Cells(3, colpm)                              '文件名称
    colMail = Cells(4, colpm)                              '邮件号码列
    rowFirst = Cells(5, colpm)                             '起始行
    colAdd1 = Cells(6, colpm)                              '附加列1
    colAdd2 = Cells(7, colpm)                              '附加列2
    
    MaxRow = ActiveSheet.UsedRange.Rows.Count
    If MaxRow >= 3 Then
        ActiveSheet.Range("A3:N" & MaxRow).ClearContents
    End If
    
    '打开文件
    MaxRow = OpenFile(DatFile)
    stNum = Sheets.Count
    rr = 1
    cc = 1
    For k1 = 1 To stNum
        MaxRow1 = Sheets(k1).[A65536].End(xlUp).Row
        If MaxRow1 >= rowFirst Then
            DataNo1 = MaxRow1 - rowFirst + 1
            arrData1 = Sheets(k1).Range(colMail & rowFirst & ":" & colMail & MaxRow1).Value
            arrAdd1 = Sheets(k1).Range(colAdd1 & rowFirst & ":" & colAdd1 & MaxRow1).Value
            arrAdd2 = Sheets(k1).Range(colAdd2 & rowFirst & ":" & colAdd2 & MaxRow1).Value
            For i = 1 To DataNo1
                Mail = CStr(arrData1(i, 1))
                '查找本表重复
                For j = i + 1 To DataNo1
                    If Mail = CStr(arrData1(j, 1)) Then
                        If cc = 1 Then
                            RepData(rr, 1) = arrData1(i, 1)
                            RepData(rr, 2) = arrAdd1(i, 1)
                            RepData(rr, 3) = arrAdd2(i, 1)
                            RepData(rr, 4) = Sheets(k1).Name
                            RepData(rr, 5) = rowFirst + i - 1
                            RepData(rr, 6) = Sheets(k1).Name      '重复项存放开始列：6、8、10、12列
                            RepData(rr, 7) = rowFirst + j - 1
                            cc = 8
                        Else
                            RepData(rr, cc) = Sheets(k1).Name
                            RepData(rr, cc + 1) = rowFirst + j - 1
                            cc = cc + 2
                        End If
                    End If
                Next j
                '查找剩余工作表重复
                For k2 = k1 + 1 To stNum
                    MaxRow2 = Sheets(k2).[A65536].End(xlUp).Row
                    If MaxRow2 >= rowFirst Then
                        DataNo2 = MaxRow2 - rowFirst + 1
                        arrData2 = Sheets(k2).Range(colMail & rowFirst & ":" & colMail & MaxRow2).Value
                        For j = 1 To DataNo2
                            If Mail = CStr(arrData2(j, 1)) Then
                                If cc = 1 Then
                                    RepData(rr, 1) = arrData1(i, 1)
                                    RepData(rr, 2) = arrAdd1(i, 1)
                                    RepData(rr, 3) = arrAdd2(i, 1)
                                    RepData(rr, 4) = Sheets(k1).Name
                                    RepData(rr, 5) = rowFirst + i - 1
                                    RepData(rr, 6) = Sheets(k2).Name      '重复项存放开始列：6、8、10、12列
                                    RepData(rr, 7) = rowFirst + j - 1
                                    cc = 8
                                Else
                                    If cc = 14 Then        '超过4个以上重复，后面标注*号，不在判断
                                        RepData(rr, cc) = "*"
                                        cc = cc + 2
                                        Exit For
                                    Else
                                        RepData(rr, cc) = Sheets(k2).Name
                                        RepData(rr, cc + 1) = rowFirst + j - 1
                                        cc = cc + 2
                                    End If
                                End If
                            End If
                        Next j
                        If cc > 14 Then Exit For     '超过4个以上重复，后面不在判断
                    End If
                Next k2
                '本号查找完毕，如果有重复，重新初始化
                If cc > 1 Then
                    rr = rr + 1
                    cc = 1
                End If
            Next i
        End If
    Next k1
    
    ActiveWindow.Close
    '保存筛重结果
    RepNo = rr - 1
    If RepNo > 0 Then
        For rr = 1 To RepNo
            For cc = 1 To 14
                Cells(rr + 2, cc) = RepData(rr, cc)
            Next cc
        Next rr
    End If
    msg = MsgBox("筛重完毕，共发现" & RepNo & "个邮件号码重复！", vbOKOnly, "ＡＨＥＭＳ：iamlaosong")

End Sub