Excel-VBA模块自定义函数实现多个单元内名称查重

  在工作中会用到姓名等名称查重的问题，例如投标供应商，股东相互持股，涉嫌关联交易。每个单元格中有一家公司全部股东名单，每个名称之间用分隔符隔开。本文给出了一种正则表达式方式查重的方法和函数实例。

Attribute VB_Name = "模块1"
    ' 本函数的作用是检查多个单元内的姓名是否有重复，有重复则返回重复的姓名字符串，没有重复则返回“无重名”
    Public Function DupCheck(ByRef Names As Range, Optional Delimiter As String = "[\s, 、；;]+") As String
        Dim SrArr() As String, DsArr() As String, dup() As Integer, TempStr As String, CellCount As Integer, n As Integer, m As Integer, NameCount As Integer, Target As String
        CellCount = Names.Count '选取的单元格数量
        NameCount = 0           '名称动态数组初始化，最低1个元素，避免出现空数组读取出现下标越界报警。作为重名计数。
        ReDim DsArr(NameCount)  'ReDim数组中的NameCount是索引的上标，所以此句为定义一个元素数组。
        DsArr(NameCount) = "" 'DsArr为目标名称数组，保存全部分割出来的名称。赋值为空字符，因为若有名称则不可能为空字符
       
        For n = 1 To CellCount
            'SrArr = Strings.Split(Names.Item(n).Value, Delimiter, -1, vbTextCompare) '把每个单元格中的字符串，以分隔符为界，分割成字符串数组，即把名称分开了，但文本中包含换行等特殊符号时会错误识别，分割Delimiter也不能用正则表达式
            SrArr = RegSplit(Names.Item(n).Value, Delimiter)    '用自制函数RegSplit来把单元格内文本分割成名称数组
            For m = LBound(SrArr) To UBound(SrArr)      '其实可以不用LBound，直接用0.LBound(srArr)查数组下标，UBound查数组上标
                SrArr(m) = Trim(SrArr(m))               '删除名称前后可能出现的空白
                If SrArr(m) <> "" Then                  '避免把空名称填入目标名称数组
                    If DsArr(NameCount) <> "" Then    '第0个元素的值为"",直接赋值，后面新增的，需要扩展数组，然后才能赋值
                        NameCount = NameCount + 1
                        ReDim Preserve DsArr(NameCount)
                    End If
                    DsArr(NameCount) = SrArr(m)
                End If
            Next m
        Next n

        TempStr = "无重名"
        For n = 0 To UBound(DsArr)
            Target = DsArr(n)   '装入查询目标
            DsArr(n) = ""       '目标自己就不算，不检测
            If Target <> "" Then
                dup = StrInArr(Target, DsArr)   '只检查名称不为空的，减少检索次数
                If dup(0) > 0 Then
                    If TempStr = "无重名" Then      '如果内容是“无重名”，表示这是第一个元素
                        TempStr = Target
                    Else
                        TempStr = TempStr + "," + Target
                    End If
                    For m = 1 To UBound(dup)        '查出的重名，直接赋值为空，减少检索比较次数
                        DsArr(dup(m)) = ""
                    Next m
                End If
            End If
        Next n
        DupCheck = TempStr
    End Function
    ' 检测Target 在Arr() 中的Index，返回整数数组，StrInArr(0) 保存的是相匹配的数量，后面的元素保存的相同项在Arr()中的位置Index
    Function StrInArr(ByVal Target As String, ByRef Arr() As String) As Integer()
        Dim Tg As String, ArrIndex() As Integer, m, n As Integer, Amount As Integer
        ReDim ArrIndex(1)
        ArrIndex(0) = 0
        StrInArr = ArrIndex
        Amount = 0
        Tg = Trim(Target)
        If Tg = "" Then Exit Function   ' 如果查找的字符串为空，则直接返回
        For n = LBound(Arr) To UBound(Arr)
            If Arr(n) <> "" And Tg = Arr(n) Then
                    Amount = Amount + 1
                    ArrIndex(0) = Amount
                    m = UBound(ArrIndex) + 1
                    ReDim Preserve ArrIndex(m)
                    ArrIndex(m) = n
            End If
        Next
        StrInArr = ArrIndex
    End Function


'以正则匹配项作为分隔符，把字符串分割成一维数组
Public Function RegSplit(ByVal TxtString$, ByVal pttn$, Optional ByVal ICase As Boolean = False, Optional ignore_empty As Boolean = True) As String()
    Dim tmp() As String, n&, p&, ma As Object, Matchs, f&
    ReDim tmp(0)    '先定义临时数组，避免无匹配时返回出错
    Set oreg = CreateObject("VBScript.RegExp")
    oreg.Global = True
    oreg.IgnoreCase = ICase
    oreg.Pattern = pttn
    oreg.MultiLine = True
    n = -1: p = 1
    Set Matchs = oreg.Execute(TxtString)
    For Each ma In Matchs
        f = ma.FirstIndex + 1
        If Not ignore_empty Or (f > p) Then
            n = n + 1
            ReDim Preserve tmp(0 To n)
            tmp(n) = Mid(TxtString, p, f - p)
        End If
        p = f + ma.Length
    Next
    If Not ignore_empty Or p <= Len(TxtString) Then
        n = n + 1
        ReDim Preserve tmp(0 To n)
        tmp(n) = Mid(TxtString, p)
    End If
    RegSplit = tmp
End Function