VBA实战技巧04： 一个用于两个列表区域比较的自定义函数

Sub QSortVar(InputValues As Variant, jStart As Long, jEnd As Long)
    Dim jStart2 As Long
    Dim jEnd2 As Long
    Dim v1 As Variant
    Dim v2 As Variant
   
    jStart2 = jStart
    jEnd2 = jEnd
 
    v1 = InputValues((jStart + (jEnd - jStart)* Rnd()), 1)
    While jStart2 < jEnd2
        While InputValues(jStart2, 1) < v1And jStart2 < jEnd
            jStart2 = jStart2 + 1
        Wend
        While InputValues(jEnd2, 1) > v1 AndjEnd2 > jStart
            jEnd2 = jEnd2 - 1
        Wend
        If jStart2 < jEnd2 Then
            v2 = InputValues(jStart2, 1)
            InputValues(jStart2, 1) =InputValues(jEnd2, 1)
            InputValues(jEnd2, 1) = v2
        End If
        If jStart2 <= jEnd2 Then
            jStart2 = jStart2 + 1
            jEnd2 = jEnd2 - 1
        End If
    Wend
    If jEnd2 > jStart Then QSortVarInputValues, jStart, jEnd2
    If jStart2 < jEnd Then QSortVarInputValues, jStart2, jEnd
 End Sub

Function BSearchMatch(LookupValue As Variant, LookupArray As Variant) As Boolean
    Dim low As Long
    Dim high As Long
    Dim middle As Long
    Dim varMiddle As Variant
    Dim jRow As Long
 
    jRow = 1
    BSearchMatch = False
    low = 0
    high = UBound(LookupArray)
 
    Do While high - low > 1
        middle = (low + high) \ 2
        varMiddle = LookupArray(middle, 1)
        If varMiddle >= LookupValue Then
            high = middle
        Else
            low = middle
        End If
    Loop
 
    If (low > 0 And high <=UBound(LookupArray)) Then
        If LookupArray(high, 1) >LookupValue Then
            jRow = low
        Else
            jRow = high
        End If
    End If
    If LookupValue = LookupArray(jRow, 1) Then BSearchMatch = True
End Function

Function LMatchExactV(LookupValue As Variant, LookupArray As Variant) As Boolean
    '使用线性搜索查找是否LookupArray中存在LookupValue
    'LookupArray必须是N行和1列的二维变体数组
    Dim j As Long
    LMatchExactV = False
    For j = 1 To UBound(LookupArray)
        If LookupValue = LookupArray(j, 1) Then
            LMatchExactV = True
            Exit For
        End If
    Next j
End Function

Function LMatchInV(LookupValue As Variant, LookupArray As Variant) As Boolean
'使用线性搜索和Instr查找是否LookupValue在LookupArray中的任意值里
'LookupArray必须是N行和1列的二维变体数组
    Dim j As Long
    Dim strLook As String
 
    LMatchInV = False
    strLook = CStr(LookupValue)
    For j = 1 To UBound(LookupArray)
        If InStr(LookupArray(j, 1), strLook)> 0 Then
            LMatchInV = True
            Exit For
        End If
    Next j
End Function

Public Function IsInList2(LookFor As Variant, _
        LookIn As Variant, _
        Optional jSorted As Long = 0, _
        Optional FindExact As Boolean = True)
   
    'jSorted
    '=0 数据未排序,但进行排序
    '=1 数据已排序 - 使用二分搜索
    '=-1 使用线性搜索
    '=2 使用集合
    '=3 使用字典
 
    Dim nLookFor As Long
    Dim nLookIn As Long
    Dim nOut As Long
    Dim vOut() As Variant
    Dim j As Long
    Dim coll As New Collection
    Dim dict As New dictionary
 
    '强制将区域转换为值
 
    LookFor = LookFor.Value2
    LookIn = LookIn.Value2
   
    '获取行数
    nLookFor = UBound(LookFor)
    nLookIn = UBound(LookIn)
    nOut = Application.Caller.Rows.Count
   
    If nLookFor < nOut Then nOut = nLookFor
    ReDim vOut(nOut, 1)  '创建输出数组
 
    If FindExact Then
        If jSorted = 0 Then
            '快速排序
            QSortVar LookIn, LBound(LookIn),UBound(LookIn)
            jSorted = 1
        ElseIf jSorted = 2 Then
            On Error Resume Next
            For j = 1 To nLookIn
                '集合
                coll.Add LookIn(j, 1), CStr(LookIn(j,1))
            Next j
        ElseIf jSorted = 3 Then
            On Error Resume Next
            For j = 1 To nLookIn
                '字典
                dict.Add LookIn(j, 1),LookIn(j, 1)
            Next j
        End If
        On Error GoTo 0
    End If
 
    For j = 1 To nOut
        If Not FindExact Then
            'instr线性搜索
            vOut(j, 1) = LMatchInV(LookFor(j,1), LookIn)
        ElseIf jSorted = 1 Then
            vOut(j, 1) =BSearchMatch(LookFor(j, 1), LookIn)    ' 二分搜索
        ElseIf jSorted = 2 Then
            '使用集合
            On Error Resume Next
            Err.Clear
            vOut(j, 1) =coll.Item(CStr(LookFor(j, 1)))
            If CLng(Err.Number) = 5 Then
                vOut(j, 1) = False
            Else
                vOut(j, 1) = True
            End If
        ElseIf jSorted = 3 Then
            '字典
            vOut(j, 1) = dict.Exists(LookFor(j,1))
        ElseIf jSorted = -1 Then
            '精确匹配
            vOut(j, 1) = LMatchExactV(LookFor(j,1), LookIn)
        Else
            vOut(j, 1) = CVErr(xlErrValue)
        End If
    Next j
 
    IsInList2 = vOut
End Function