|
|
为了让非Office365的电脑也使用Xlookup,对楼主的代码加入一个if_not_found的返回值。
'参考YZC51的仿XLOOKUP代码进行修改，YZC51函数代码中没有对找不到key的异常处理。
'增加了找不到时的返回值if_not_found
'逻辑错误检查没问题
'这个自定义函数，，如果定义了if_not_found,则返回自定义的值
'Case1.对于找不到lookup_value时，会返回错误#VALUE!
'Case2.能找到lookup_value，但lookup_array和return_range的大小不同，也可返回(这不会导致返回错误的查询结果)，因此和Range大小相同一样，没问题。不会返回#VALUE!。
'Case3.能找到lookup_value，未强制lookup_array和return_range起始行号相同，所以如果lookup_array和return_range的大小相同，但不小心错位了，就会导致返回错误的查询结果，但不会返回#VALUE!。
'虽然Case3不严谨，但Office提供的xlookup函数，有同样的问题，只能靠使用者注意两个Range不要错位。不会返回#VALUE!
'因此这个自定义函数，和微软的Xlookup功能在使用上是一样的
Function XLOOKUP(ByRef lookup_value As Variant, ByRef lookup_array As Range, ByRef return_range As Range, ByRef if_not_found As Variant, Optional ByRef match_mode As Integer = 0, Optional ByRef search_mode As Integer = 1)
Dim arr, arr1, arr2()
Dim k As Integer
Dim x As Integer
Dim j As Integer
Dim s
Dim flg
On Error GoTo not_found_value
If Len(lookup_value) = 0 Then lookup_value = 0
arr = lookup_array
arr1 = return_range
If UBound(arr1) = 1 Then
arr1 = Application.Transpose(arr1)
arr = Application.Transpose(arr)
End If
ReDim arr2(1 To 1)
For x = 1 To UBound(arr1)
If match_mode = 2 Then
flg = arr(x, 1) Like lookup_value '通配符匹配
ElseIf match_mode = 3 Then
flg = InStr(arr(x, 1), lookup_value) '包含匹配
Else
flg = (arr(x, 1) = lookup_value) '精确匹配
End If
If flg And search_mode = 1 Then
If UBound(arr1, 2) > 1 Then
XLOOKUP = arr1(x, 1)
With Application.ThisCell
For j = 1 To UBound(arr1, 2) '自动填充
If .Offset(, j) = "" Then s = Null Else s = "*"
.Offset(, j).Replace s, arr1(x, j + 1)
Next j
End With
End If
XLOOKUP = arr1(x, 1)
Exit Function
Else
If arr(x, 1) = lookup_value Then
k = k + 1
ReDim Preserve arr2(1 To k)
arr2(k) = arr1(x, 1)
End If
End If
Next x
If Abs(match_mode) = 1 Then
XLOOKUP = JS(lookup_value, lookup_array, return_range, match_mode)
Else
If search_mode = 0 Then XLOOKUP = Join(arr2, ",")
If search_mode < 0 Then XLOOKUP = arr2(k)
If search_mode > 0 Then XLOOKUP = arr2(search_mode)
End If
not_found_value:
XLOOKUP = if_not_found
On Error GoTo 0
End Function
Function JS(ByRef J1 As Variant, ByRef R1 As Range, ByRef R2 As Range, ByRef m As Integer)
Dim Jarr1, Jarr2
Dim x As Integer
Jarr1 = R1
Jarr2 = R2
For x = 1 To UBound(Jarr1)
If x + 1 > UBound(Jarr1) Then
JS = Jarr2(x, 1)
Exit Function
ElseIf J1 >= Jarr1(x, 1) And J1 < Jarr1(x + 1, 1) Then
If m = -1 Then JS = Jarr2(x, 1) Else JS = Jarr2(x + 1, 1)
Exit Function
End If
Next x
End Function
'根据当前的列序数，取得列号
'传入参数为Excel中列的序号。例如：传入1返回A，传入2返回B。
'用于给导入的数据加边框
Function Fun_GetColName(ByVal argColumn As Integer) As String
Dim strColName As String
Dim iNum, iMod As Integer
iNum = argColumn \ 26
iMod = argColumn Mod 26
If (iMod = 0) Then
If (iNum = 1) Then
strColName = Chr(90)
Else
strColName = Chr(65 + iNum - 2) + Chr(90)
End If
Else
If (iNum = 0) Then
strColName = Chr(65 + iMod - 1)
Else
strColName = Chr(65 + iNum - 1) + Chr(65 + iMod - 1)
End If
End If
Fun_GetColName = strColName
End Function |
|
楼主: YZC51
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-11-10 23:32
同问 
