【自定义函数】编码-查询-匹配

自定义编码匹配

在wps vb环境写一个新的excel函数名为编码匹配，第一个参数指定待匹配文本所在单元格（相对引用），第二个参数指定关键词区域（绝对引用，一行或者一列单元格），第三个参数指定一个自定义编码区域（绝对引用一行或者一列，但是要检查其长度是否与关键词区域相等，不等则显示错误），完成参数填写以后，将参数2中每个关键词依次在参数1中进行匹配，如果存在则记录其次序，返回值参数3中与改次序相同的自定义编码文本，如果存在多个匹配结果，用逗号间隔后返回
gpt错误是把关键词和编码定义为了String，应该是Variant
改进：跳过关键词的空值，这样引用区域可以预留空间

Function 编码匹配(待匹配文本 As Range, 关键词区域 As Range, 自定义编码区域 As Range) As StringDim 关键词() As Variant ' 关键词数组Dim 编码() As Variant ' 编码数组Dim 匹配结果 As String ' 最终匹配结果Dim i As Long ' 循环变量Dim 匹配次序 As Collection ' 用于存储匹配次序Dim 匹配项 As Variant ' 用于遍历匹配次序集合' 检查关键词区域和自定义编码区域的长度是否相等If 关键词区域.Count <> 自定义编码区域.Count Then编码匹配 = "错误：关键词区域和自定义编码区域长度不匹配"Exit FunctionEnd If' 将关键词区域和自定义编码区域的值存入数组关键词 = 关键词区域.Value编码 = 自定义编码区域.Value' 检查待匹配文本是否为空If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then编码匹配 = ""Exit FunctionEnd If' 初始化匹配次序集合Set 匹配次序 = New Collection' 遍历关键词区域，检查关键词是否在待匹配文本中For i = LBound(关键词, 1) To UBound(关键词, 1)' 检查关键词是否为空If Not IsEmpty(关键词(i, 1)) And Trim(关键词(i, 1)) <> "" Then' 检查关键词是否在待匹配文本中If InStr(1, 待匹配文本.Value, 关键词(i, 1), vbTextCompare) > 0 Then匹配次序.Add iEnd IfEnd IfNext i' 如果没有匹配结果，返回空字符串If 匹配次序.Count = 0 Then编码匹配 = ""Exit FunctionEnd If' 根据匹配次序获取对应的自定义编码For Each 匹配项 In 匹配次序If 匹配结果 = "" Then匹配结果 = 编码(匹配项, 1)Else匹配结果 = 匹配结果 & "," & 编码(匹配项, 1)End IfNext 匹配项' 返回最终结果编码匹配 = 匹配结果
End Function

编码匹配改进

对以下代码进行修改和改进，以提供个性化的匹配，

做一些预处理，先用一个另外的’关键词排序数组’将’关键词’中的数列根据字符串长度升序排列，随后自上而下遍历，将较短的关键词在比它长的其他所有关键词中进行搜索，如果匹配成功，较短一方添加到’上级’数组，较长一方添加到’下级’数组，
在For i = LBound(关键词, 1) To UBound(关键词, 1)这个遍历关键词过程中，如果当前关键词在上级数组中且待匹配文本搜索成功，请将所有的下级数组中的关键词在待匹配文本中进行搜索，如果有一个下级数组关键词匹配成功，说明这个待匹配文本可能是对应下级数组关键词的编码，而不适用当前上级关键词对应的编码，所以不添加匹配次序

Function 编码匹配(待匹配文本 As Range, 关键词区域 As Range, 自定义编码区域 As Range) As StringDim 关键词() As Variant ' 关键词数组Dim 编码() As Variant ' 编码数组Dim 匹配结果 As String ' 最终匹配结果Dim i As Long, j As Long ' 循环变量Dim 匹配次序 As Collection ' 用于存储匹配次序Dim 匹配项 As Variant ' 用于遍历匹配次序集合Dim 上级数组() As Boolean ' 标记是否为上级关键词Dim 下级数组() As Collection ' 存储每个关键词的下级关键词' 检查关键词区域和自定义编码区域的长度是否相等If 关键词区域.Count <> 自定义编码区域.Count Then编码匹配 = "错误：关键词区域和自定义编码区域长度不匹配"Exit FunctionEnd If' 将关键词区域和自定义编码区域的值存入数组关键词 = 关键词区域.Value编码 = 自定义编码区域.Value' 检查待匹配文本是否为空If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then编码匹配 = ""Exit FunctionEnd If' 初始化匹配次序集合和上级/下级数组Set 匹配次序 = New CollectionReDim 上级数组(LBound(关键词, 1) To UBound(关键词, 1))ReDim 下级数组(LBound(关键词, 1) To UBound(关键词, 1))For i = LBound(关键词, 1) To UBound(关键词, 1)Set 下级数组(i) = New CollectionNext i' 按字符串长度对关键词进行排序Dim 排序数组() As VariantReDim 排序数组(LBound(关键词, 1) To UBound(关键词, 1))For i = LBound(关键词, 1) To UBound(关键词, 1)排序数组(i) = Array(i, Len(Trim(关键词(i, 1))))Next iQuickSort 排序数组, LBound(排序数组), UBound(排序数组)' 遍历排序后的关键词，构建上级和下级数组For i = LBound(排序数组) To UBound(排序数组)Dim 当前关键词索引 As Long当前关键词索引 = 排序数组(i)(0)For j = i + 1 To UBound(排序数组)Dim 比较关键词索引 As Long比较关键词索引 = 排序数组(j)(0)If InStr(1, 关键词(比较关键词索引, 1), 关键词(当前关键词索引, 1), vbTextCompare) > 0 Then上级数组(比较关键词索引) = True下级数组(当前关键词索引).Add 比较关键词索引End IfNext jNext i' 遍历关键词区域，检查关键词是否在待匹配文本中For i = LBound(关键词, 1) To UBound(关键词, 1)' 检查关键词是否为空If Not IsEmpty(关键词(i, 1)) And Trim(关键词(i, 1)) <> "" Then' 检查关键词是否在待匹配文本中If InStr(1, 待匹配文本.Value, 关键词(i, 1), vbTextCompare) > 0 Then' 检查是否为上级关键词If Not 上级数组(i) Then匹配次序.Add iElse' 检查下级关键词是否匹配成功Dim 下级关键词匹配成功 As Boolean下级关键词匹配成功 = FalseDim 下级关键词 As VariantFor Each 下级关键词 In 下级数组(i)If InStr(1, 待匹配文本.Value, 关键词(下级关键词, 1), vbTextCompare) > 0 Then下级关键词匹配成功 = TrueExit ForEnd IfNext 下级关键词' 如果没有下级关键词匹配成功，则添加当前上级关键词If Not 下级关键词匹配成功 Then匹配次序.Add iEnd IfEnd IfEnd IfEnd IfNext i' 如果没有匹配结果，返回空字符串If 匹配次序.Count = 0 Then编码匹配 = ""Exit FunctionEnd If' 根据匹配次序获取对应的自定义编码For Each 匹配项 In 匹配次序If 匹配结果 = "" Then匹配结果 = 编码(匹配项, 1)Else匹配结果 = 匹配结果 & "," & 编码(匹配项, 1)End IfNext 匹配项' 返回最终结果编码匹配 = 匹配结果
End Function' 快速排序算法
Sub QuickSort(arr, ByVal first As Long, ByVal last As Long)Dim lower As Long, upper As Long, pivot As Variant, temp As Variantlower = first: upper = lastpivot = arr((first + last) \ 2)(1)Do While lower <= upperDo While (arr(lower)(1) < pivot And lower < last)lower = lower + 1LoopDo While (pivot < arr(upper)(1) And upper > first)upper = upper - 1LoopIf lower <= upper Thentemp = arr(lower)arr(lower) = arr(upper)arr(upper) = templower = lower + 1upper = upper - 1End IfLoopIf first < upper Then QuickSort arr, first, upperIf lower < last Then QuickSort arr, lower, last
End Sub

sheet来源汇总

在wps vb环境写一个新的excel函数名为来源汇总，第一个参数指定待匹配文本所在单元格（相对引用且不得为空），第二个参数开始指定sheet页（具体方式是选中任意区域，在处理时仅识别sheet名），当第二个参数不为空时增加第三个参数用来添加新的检索sheet页，遍历所有的检索区域，当待匹配文本包含在检索区域的某个单元格的文本值中，将该单元格所在sheet名+单元格位置如“A1”这样的字串添加到文返回值中
考虑检索区域是二维表格，且为该sheet中包含所有数据的最小矩形区域
注意在使用时填A1绝对引用。

Function 来源汇总(待匹配文本 As Range, ParamArray 检索区域() As Variant) As StringDim 匹配结果 As StringDim 区域 As VariantDim 工作表 As WorksheetDim 单元格 As RangeDim 匹配地址 As StringDim 区域索引 As Long' 检查待匹配文本是否为空If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then来源汇总 = "EmptyError"Exit FunctionEnd If' 初始化匹配结果匹配结果 = ""' 遍历所有指定的检索区域For 区域索引 = LBound(检索区域) To UBound(检索区域)' 检查当前区域是否为空If Not IsEmpty(检索区域(区域索引)) Then' 获取区域所在的工作表Set 工作表 = 检索区域(区域索引).Parent' 遍历工作表中的每个单元格（仅在已使用的范围内）For Each 单元格 In 工作表.UsedRange' 检查单元格是否包含待匹配文本If InStr(1, 单元格.Value, 待匹配文本.Value, vbTextCompare) > 0 Then' 构造匹配地址匹配地址 = 工作表.Name & "!" & 单元格.Address(False, False)' 将匹配地址添加到结果中If 匹配结果 = "" Then匹配结果 = 匹配地址Else匹配结果 = 匹配结果 & "," & 匹配地址End IfEnd IfNext 单元格End IfNext 区域索引' 返回最终结果来源汇总 = 匹配结果
End Function

来源汇总改进

进行来源汇总时也对关键词做一个上级和下级的区分，然后在搜索区域匹配时，上级关键词要剔除掉对应的下级关键词的匹配结果

Function 来源汇总(待匹配文本 As Range, ParamArray 检索区域() As Variant) As StringDim 匹配结果 As StringDim 区域 As VariantDim 工作表 As WorksheetDim 单元格 As RangeDim 匹配地址 As StringDim 区域索引 As LongDim 关键词() As VariantDim 上级数组() As BooleanDim 下级数组() As CollectionDim i As Long, j As Long' 检查待匹配文本是否为空If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then来源汇总 = "----"Exit FunctionEnd If' 初始化匹配结果匹配结果 = ""' 获取所有关键词并初始化上级和下级数组ReDim 关键词(1 To 1)ReDim 上级数组(1 To 1)ReDim 下级数组(1 To 1)Set 下级数组(1) = New Collection' 遍历所有指定的检索区域For 区域索引 = LBound(检索区域) To UBound(检索区域)' 检查当前区域是否为空If Not IsEmpty(检索区域(区域索引)) Then' 获取区域所在的工作表Set 工作表 = 检索区域(区域索引).Parent' 遍历工作表中的每个单元格（仅在已使用的范围内）For Each 单元格 In 工作表.UsedRange' 检查单元格是否包含待匹配文本If InStr(1, 单元格.Value, 待匹配文本.Value, vbTextCompare) > 0 Then' 构造匹配地址匹配地址 = 工作表.Name & "!" & 单元格.Address(False, False)' 检查是否为上级关键词If Not 上级数组(i) Then' 添加匹配地址到结果If 匹配结果 = "" Then匹配结果 = 匹配地址Else匹配结果 = 匹配结果 & "," & 匹配地址End IfElse' 检查下级关键词是否匹配成功Dim 下级关键词匹配成功 As Boolean下级关键词匹配成功 = FalseDim 下级关键词 As VariantFor Each 下级关键词 In 下级数组(i)If InStr(1, 单元格.Value, 下级关键词, vbTextCompare) > 0 Then下级关键词匹配成功 = TrueExit ForEnd IfNext 下级关键词' 如果没有下级关键词匹配成功，则添加当前上级关键词If Not 下级关键词匹配成功 ThenIf 匹配结果 = "" Then匹配结果 = 匹配地址Else匹配结果 = 匹配结果 & "," & 匹配地址End IfEnd IfEnd IfEnd IfNext 单元格End IfNext 区域索引' 返回最终结果来源汇总 = 匹配结果
End Function

END