【自定义函数】多条件查询VLOOKUPIFS

wmy920130

拿出来看看

hgp212

Function VLOOKUPIFS(ReturnRange As Range, ParamArray Param() As Variant)
   
    Dim ParamCnt, IfRngCnt, FindCnt, MinCnt, MinIndex As Long
    Dim beginRow, FindRow, MatchRow, YCnt As Long
    Dim IfRng As Range
    Dim IfVal As String
    Dim temp0, temp1
   
    MinCnt = 1048576                        'excel2013最大行数
    ParamCnt = UBound(Param)
    IfRngCnt = (ParamCnt + 1) / 2
   
    For i = 0 To IfRngCnt - 1
        Set IfRng = Param(2 * i)
        IfVal = Param(2 * i + 1)

        FindCnt = Application.CountIf(IfRng, IfVal)
        If FindCnt < MinCnt Then
            MinCnt = FindCnt
            MinIndex = 2 * i
        End If
        
        Set IfRng = Nothing
    Next i
   
    Set IfRng = Param(MinIndex)
    IfVal = Param(MinIndex + 1)
   
    FindRow = 0
    beginRow = 1
    YCnt = 0
   
    If IfVal Like ">*" Or IfVal Like "<*" Or IfVal Like "<>*" Then
   
            For i = 1 To MinCnt
                    For m = beginRow To IfRng.Rows.Count
                            beginRow = m + 1
                           
                            temp0 = IfRng.Cells(m, 1).Value
                            temp1 = IfVal
                           
                            If IsNumeric(temp0) Then
                                If temp1 Like ">*" And Not (temp1 Like "*=*") And temp0 > Replace(temp1, ">", "") Then
                                    MatchRow = m
                                    Exit For
                                ElseIf temp1 Like ">=*" And temp0 >= Replace(temp1, ">=", "") Then
                                    MatchRow = m
                                    Exit For
                                ElseIf temp1 Like "<*" And Not (temp1 Like "*=*") And temp0 < Replace(temp1, "<", "") Then
                                    MatchRow = m
                                    Exit For
                                ElseIf temp1 Like "<=*" And temp0 <= Replace(temp1, "<=", "") Then
                                    MatchRow = m
                                    Exit For
                                End If
                            End If
                                
                            If temp1 Like "<>*" And temp0 <> Replace(temp1, "<>", "") Then
                                MatchRow = m
                                Exit For
                            End If
                    Next m

                    YCnt = 0
                    For j = 0 To IfRngCnt - 1
                            temp0 = Param(2 * j).Cells(MatchRow, 1).Value
                            temp1 = Param(2 * j + 1)
                        
                            If temp1 Like ">*" And Not (temp1 Like "*=*") And temp0 > Replace(temp1, ">", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp1 Like ">=*" And temp0 >= Replace(temp1, ">=", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp1 Like "<*" And Not (temp1 Like "*=*") And temp0 < Replace(temp1, "<", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp1 Like "<=*" And temp0 <= Replace(temp1, "<=", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp1 Like "<>*" And temp0 <> Replace(temp1, "<>", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp0 = temp1 Then
                                YCnt = YCnt + 1
                            Else
                                Exit For
                            End If
                    Next j
                    
                    If YCnt = IfRngCnt Then
                        Exit For
                    End If
            Next i

    Else
            For i = 1 To MinCnt
                    FindRow = Application.Match(IfVal, IfRng.Range(Cells(beginRow, 1), Cells(IfRng.Rows.Count, 1)), 0)
                    MatchRow = beginRow + FindRow - 1
                    beginRow = MatchRow + 1
                    
                    YCnt = 0
                    For j = 0 To IfRngCnt - 1
                            temp0 = Param(2 * j).Cells(MatchRow, 1).Value
                            temp1 = Param(2 * j + 1)
                        
                            If temp1 Like ">*" And Not (temp1 Like "*=*") And temp0 > Replace(temp1, ">", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp1 Like ">=*" And temp0 >= Replace(temp1, ">=", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp1 Like "<*" And Not (temp1 Like "*=*") And temp0 < Replace(temp1, "<", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp1 Like "<=*" And temp0 <= Replace(temp1, "<=", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp1 Like "<>*" And temp0 <> Replace(temp1, "<>", "") Then
                                YCnt = YCnt + 1
                            ElseIf temp0 = temp1 Then
                                YCnt = YCnt + 1
                            Else
                                Exit For
                            End If
                    Next j
                    
                    If YCnt = IfRngCnt Then
                        Exit For
                    End If
            Next i
        
    End If
         
    If YCnt = IfRngCnt Then
        VLOOKUPIFS = ReturnRange.Cells(MatchRow, 1).Value
    Else
        VLOOKUPIFS = CVErr(xlErrValue)    '返回一个错误值
    End If

End Function




我参照楼主的代码做了算法上的修正，效率应该很高的，让大家测试一下。。不过有一个问题，在跨sheet使用时，如果条件有空白的会出来错误错，但在同一个sheet使用时是正确的，不知道怎么回事，看谁能找出问题来！

GG函数

群文件或百度搜索“微软函数 for vba”，加载后你就有微软工程师(GG)的函数了