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

自定义编码匹配

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

Function 编码匹配(待匹配文本 As Range, 关键词区域 As Range, 自定义编码区域 As Range) As String
    Dim 关键词() As Variant ' 关键词数组
    Dim 编码() As Variant ' 编码数组
    Dim 匹配结果 As String ' 最终匹配结果
    Dim i As Long ' 循环变量
    Dim 匹配次序 As Collection ' 用于存储匹配次序
    Dim 匹配项 As Variant ' 用于遍历匹配次序集合

    ' 检查关键词区域和自定义编码区域的长度是否相等
    If 关键词区域.Count <> 自定义编码区域.Count Then
        编码匹配 = "错误：关键词区域和自定义编码区域长度不匹配"
        Exit Function
    End If

    ' 将关键词区域和自定义编码区域的值存入数组
    关键词 = 关键词区域.Value
    编码 = 自定义编码区域.Value

    ' 检查待匹配文本是否为空
    If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then
        编码匹配 = ""
        Exit Function
    End 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 i
            End If
        End If
    Next i

    ' 如果没有匹配结果，返回空字符串
    If 匹配次序.Count = 0 Then
        编码匹配 = ""
        Exit Function
    End If

    ' 根据匹配次序获取对应的自定义编码
    For Each 匹配项 In 匹配次序
        If 匹配结果 = "" Then
            匹配结果 = 编码(匹配项, 1)
        Else
            匹配结果 = 匹配结果 & "," & 编码(匹配项, 1)
        End If
    Next 匹配项

    ' 返回最终结果
    编码匹配 = 匹配结果
End Function

编码匹配改进

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

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

Function 编码匹配(待匹配文本 As Range, 关键词区域 As Range, 自定义编码区域 As Range) As String
    Dim 关键词() 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 Function
    End If

    ' 将关键词区域和自定义编码区域的值存入数组
    关键词 = 关键词区域.Value
    编码 = 自定义编码区域.Value

    ' 检查待匹配文本是否为空
    If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then
        编码匹配 = ""
        Exit Function
    End If

    ' 初始化匹配次序集合和上级/下级数组
    Set 匹配次序 = New Collection
    ReDim 上级数组(LBound(关键词, 1) To UBound(关键词, 1))
    ReDim 下级数组(LBound(关键词, 1) To UBound(关键词, 1))
    For i = LBound(关键词, 1) To UBound(关键词, 1)
        Set 下级数组(i) = New Collection
    Next i

    ' 按字符串长度对关键词进行排序
    Dim 排序数组() As Variant
    ReDim 排序数组(LBound(关键词, 1) To UBound(关键词, 1))
    For i = LBound(关键词, 1) To UBound(关键词, 1)
        排序数组(i) = Array(i, Len(Trim(关键词(i, 1))))
    Next i
    QuickSort 排序数组, 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 If
        Next j
    Next 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 i
                Else
                    ' 检查下级关键词是否匹配成功
                    Dim 下级关键词匹配成功 As Boolean
                    下级关键词匹配成功 = False
                    Dim 下级关键词 As Variant
                    For Each 下级关键词 In 下级数组(i)
                        If InStr(1, 待匹配文本.Value, 关键词(下级关键词, 1), vbTextCompare) > 0 Then
                            下级关键词匹配成功 = True
                            Exit For
                        End If
                    Next 下级关键词
                    ' 如果没有下级关键词匹配成功，则添加当前上级关键词
                    If Not 下级关键词匹配成功 Then
                        匹配次序.Add i
                    End If
                End If
            End If
        End If
    Next i

    ' 如果没有匹配结果，返回空字符串
    If 匹配次序.Count = 0 Then
        编码匹配 = ""
        Exit Function
    End If

    ' 根据匹配次序获取对应的自定义编码
    For Each 匹配项 In 匹配次序
        If 匹配结果 = "" Then
            匹配结果 = 编码(匹配项, 1)
        Else
            匹配结果 = 匹配结果 & "," & 编码(匹配项, 1)
        End If
    Next 匹配项

    ' 返回最终结果
    编码匹配 = 匹配结果
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 Variant
    lower = first: upper = last
    pivot = arr((first + last) \ 2)(1)
    Do While lower <= upper
        Do While (arr(lower)(1) < pivot And lower < last)
            lower = lower + 1
        Loop
        Do While (pivot < arr(upper)(1) And upper > first)
            upper = upper - 1
        Loop
        If lower <= upper Then
            temp = arr(lower)
            arr(lower) = arr(upper)
            arr(upper) = temp
            lower = lower + 1
            upper = upper - 1
        End If
    Loop
    If first < upper Then QuickSort arr, first, upper
    If 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 String
    Dim 匹配结果 As String
    Dim 区域 As Variant
    Dim 工作表 As Worksheet
    Dim 单元格 As Range
    Dim 匹配地址 As String
    Dim 区域索引 As Long

    ' 检查待匹配文本是否为空
    If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then
        来源汇总 = "EmptyError"
        Exit Function
    End 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 If
                End If
            Next 单元格
        End If
    Next 区域索引

    ' 返回最终结果
    来源汇总 = 匹配结果
End Function

来源汇总改进

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

Function 来源汇总(待匹配文本 As Range, ParamArray 检索区域() As Variant) As String
    Dim 匹配结果 As String
    Dim 区域 As Variant
    Dim 工作表 As Worksheet
    Dim 单元格 As Range
    Dim 匹配地址 As String
    Dim 区域索引 As Long
    Dim 关键词() As Variant
    Dim 上级数组() As Boolean
    Dim 下级数组() As Collection
    Dim i As Long, j As Long

    ' 检查待匹配文本是否为空
    If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then
        来源汇总 = "----"
        Exit Function
    End 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 If
                    Else
                        ' 检查下级关键词是否匹配成功
                        Dim 下级关键词匹配成功 As Boolean
                        下级关键词匹配成功 = False
                        Dim 下级关键词 As Variant
                        For Each 下级关键词 In 下级数组(i)
                            If InStr(1, 单元格.Value, 下级关键词, vbTextCompare) > 0 Then
                                下级关键词匹配成功 = True
                                Exit For
                            End If
                        Next 下级关键词
                        ' 如果没有下级关键词匹配成功，则添加当前上级关键词
                        If Not 下级关键词匹配成功 Then
                            If 匹配结果 = "" Then
                                匹配结果 = 匹配地址
                            Else
                                匹配结果 = 匹配结果 & "," & 匹配地址
                            End If
                        End If
                    End If
                End If
            Next 单元格
        End If
    Next 区域索引

    ' 返回最终结果
    来源汇总 = 匹配结果
End Function