IT评测·应用市场-qidao123.com

标题: 【自定义函数】编码-查询-匹配 [打印本页]

---

作者: 守听    时间: 2025-1-26 11:00
标题: 【自定义函数】编码-查询-匹配
自定义编码匹配

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

1. Function 编码匹配(待匹配文本 As Range, 关键词区域 As Range, 自定义编码区域 As Range) As String
2.     Dim 关键词() As Variant ' 关键词数组
3.     Dim 编码() As Variant ' 编码数组
4.     Dim 匹配结果 As String ' 最终匹配结果
5.     Dim i As Long ' 循环变量
6.     Dim 匹配次序 As Collection ' 用于存储匹配次序
7.     Dim 匹配项 As Variant ' 用于遍历匹配次序集合
9.     ' 检查关键词区域和自定义编码区域的长度是否相等
10.     If 关键词区域.Count <> 自定义编码区域.Count Then
11.         编码匹配 = "错误：关键词区域和自定义编码区域长度不匹配"
12.         Exit Function
13.     End If
15.     ' 将关键词区域和自定义编码区域的值存入数组
16.     关键词 = 关键词区域.Value
17.     编码 = 自定义编码区域.Value
19.     ' 检查待匹配文本是否为空
20.     If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then
21.         编码匹配 = ""
22.         Exit Function
23.     End If
25.     ' 初始化匹配次序集合
26.     Set 匹配次序 = New Collection
28.     ' 遍历关键词区域，检查关键词是否在待匹配文本中
29.     For i = LBound(关键词, 1) To UBound(关键词, 1)
30.         ' 检查关键词是否为空
31.         If Not IsEmpty(关键词(i, 1)) And Trim(关键词(i, 1)) <> "" Then
32.             ' 检查关键词是否在待匹配文本中
33.             If InStr(1, 待匹配文本.Value, 关键词(i, 1), vbTextCompare) > 0 Then
34.                 匹配次序.Add i
35.             End If
36.         End If
37.     Next i
39.     ' 如果没有匹配结果，返回空字符串
40.     If 匹配次序.Count = 0 Then
41.         编码匹配 = ""
42.         Exit Function
43.     End If
45.     ' 根据匹配次序获取对应的自定义编码
46.     For Each 匹配项 In 匹配次序
47.         If 匹配结果 = "" Then
48.             匹配结果 = 编码(匹配项, 1)
49.         Else
50.             匹配结果 = 匹配结果 & "," & 编码(匹配项, 1)
51.         End If
52.     Next 匹配项
54.     ' 返回最终结果
55.     编码匹配 = 匹配结果
56. End Function

复制代码

编码匹配改进

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

复制代码

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

1. Function 编码匹配(待匹配文本 As Range, 关键词区域 As Range, 自定义编码区域 As Range) As String
2.     Dim 关键词() As Variant ' 关键词数组
3.     Dim 编码() As Variant ' 编码数组
4.     Dim 匹配结果 As String ' 最终匹配结果
5.     Dim i As Long, j As Long ' 循环变量
6.     Dim 匹配次序 As Collection ' 用于存储匹配次序
7.     Dim 匹配项 As Variant ' 用于遍历匹配次序集合
8.     Dim 上级数组() As Boolean ' 标记是否为上级关键词
9.     Dim 下级数组() As Collection ' 存储每个关键词的下级关键词
11.     ' 检查关键词区域和自定义编码区域的长度是否相等
12.     If 关键词区域.Count <> 自定义编码区域.Count Then
13.         编码匹配 = "错误：关键词区域和自定义编码区域长度不匹配"
14.         Exit Function
15.     End If
17.     ' 将关键词区域和自定义编码区域的值存入数组
18.     关键词 = 关键词区域.Value
19.     编码 = 自定义编码区域.Value
21.     ' 检查待匹配文本是否为空
22.     If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then
23.         编码匹配 = ""
24.         Exit Function
25.     End If
27.     ' 初始化匹配次序集合和上级/下级数组
28.     Set 匹配次序 = New Collection
29.     ReDim 上级数组(LBound(关键词, 1) To UBound(关键词, 1))
30.     ReDim 下级数组(LBound(关键词, 1) To UBound(关键词, 1))
31.     For i = LBound(关键词, 1) To UBound(关键词, 1)
32.         Set 下级数组(i) = New Collection
33.     Next i
35.     ' 按字符串长度对关键词进行排序
36.     Dim 排序数组() As Variant
37.     ReDim 排序数组(LBound(关键词, 1) To UBound(关键词, 1))
38.     For i = LBound(关键词, 1) To UBound(关键词, 1)
39.         排序数组(i) = Array(i, Len(Trim(关键词(i, 1))))
40.     Next i
41.     QuickSort 排序数组, LBound(排序数组), UBound(排序数组)
43.     ' 遍历排序后的关键词，构建上级和下级数组
44.     For i = LBound(排序数组) To UBound(排序数组)
45.         Dim 当前关键词索引 As Long
46.         当前关键词索引 = 排序数组(i)(0)
47.         For j = i + 1 To UBound(排序数组)
48.             Dim 比较关键词索引 As Long
49.             比较关键词索引 = 排序数组(j)(0)
50.             If InStr(1, 关键词(比较关键词索引, 1), 关键词(当前关键词索引, 1), vbTextCompare) > 0 Then
51.                 上级数组(比较关键词索引) = True
52.                 下级数组(当前关键词索引).Add 比较关键词索引
53.             End If
54.         Next j
55.     Next i
57.     ' 遍历关键词区域，检查关键词是否在待匹配文本中
58.     For i = LBound(关键词, 1) To UBound(关键词, 1)
59.         ' 检查关键词是否为空
60.         If Not IsEmpty(关键词(i, 1)) And Trim(关键词(i, 1)) <> "" Then
61.             ' 检查关键词是否在待匹配文本中
62.             If InStr(1, 待匹配文本.Value, 关键词(i, 1), vbTextCompare) > 0 Then
63.                 ' 检查是否为上级关键词
64.                 If Not 上级数组(i) Then
65.                     匹配次序.Add i
66.                 Else
67.                     ' 检查下级关键词是否匹配成功
68.                     Dim 下级关键词匹配成功 As Boolean
69.                     下级关键词匹配成功 = False
70.                     Dim 下级关键词 As Variant
71.                     For Each 下级关键词 In 下级数组(i)
72.                         If InStr(1, 待匹配文本.Value, 关键词(下级关键词, 1), vbTextCompare) > 0 Then
73.                             下级关键词匹配成功 = True
74.                             Exit For
75.                         End If
76.                     Next 下级关键词
77.                     ' 如果没有下级关键词匹配成功，则添加当前上级关键词
78.                     If Not 下级关键词匹配成功 Then
79.                         匹配次序.Add i
80.                     End If
81.                 End If
82.             End If
83.         End If
84.     Next i
86.     ' 如果没有匹配结果，返回空字符串
87.     If 匹配次序.Count = 0 Then
88.         编码匹配 = ""
89.         Exit Function
90.     End If
92.     ' 根据匹配次序获取对应的自定义编码
93.     For Each 匹配项 In 匹配次序
94.         If 匹配结果 = "" Then
95.             匹配结果 = 编码(匹配项, 1)
96.         Else
97.             匹配结果 = 匹配结果 & "," & 编码(匹配项, 1)
98.         End If
99.     Next 匹配项
101.     ' 返回最终结果
102.     编码匹配 = 匹配结果
103. End Function
105. ' 快速排序算法
106. Sub QuickSort(arr, ByVal first As Long, ByVal last As Long)
107.     Dim lower As Long, upper As Long, pivot As Variant, temp As Variant
108.     lower = first: upper = last
109.     pivot = arr((first + last) \ 2)(1)
110.     Do While lower <= upper
111.         Do While (arr(lower)(1) < pivot And lower < last)
112.             lower = lower + 1
113.         Loop
114.         Do While (pivot < arr(upper)(1) And upper > first)
115.             upper = upper - 1
116.         Loop
117.         If lower <= upper Then
118.             temp = arr(lower)
119.             arr(lower) = arr(upper)
120.             arr(upper) = temp
121.             lower = lower + 1
122.             upper = upper - 1
123.         End If
124.     Loop
125.     If first < upper Then QuickSort arr, first, upper
126.     If lower < last Then QuickSort arr, lower, last
127. End Sub

复制代码

sheet泉源汇总

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

1. Function 来源汇总(待匹配文本 As Range, ParamArray 检索区域() As Variant) As String
2.     Dim 匹配结果 As String
3.     Dim 区域 As Variant
4.     Dim 工作表 As Worksheet
5.     Dim 单元格 As Range
6.     Dim 匹配地址 As String
7.     Dim 区域索引 As Long
9.     ' 检查待匹配文本是否为空
10.     If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then
11.         来源汇总 = "EmptyError"
12.         Exit Function
13.     End If
15.     ' 初始化匹配结果
16.     匹配结果 = ""
18.     ' 遍历所有指定的检索区域
19.     For 区域索引 = LBound(检索区域) To UBound(检索区域)
20.         ' 检查当前区域是否为空
21.         If Not IsEmpty(检索区域(区域索引)) Then
22.             ' 获取区域所在的工作表
23.             Set 工作表 = 检索区域(区域索引).Parent
25.             ' 遍历工作表中的每个单元格（仅在已使用的范围内）
26.             For Each 单元格 In 工作表.UsedRange
27.                 ' 检查单元格是否包含待匹配文本
28.                 If InStr(1, 单元格.Value, 待匹配文本.Value, vbTextCompare) > 0 Then
29.                     ' 构造匹配地址
30.                     匹配地址 = 工作表.Name & "!" & 单元格.Address(False, False)
31.                     ' 将匹配地址添加到结果中
32.                     If 匹配结果 = "" Then
33.                         匹配结果 = 匹配地址
34.                     Else
35.                         匹配结果 = 匹配结果 & "," & 匹配地址
36.                     End If
37.                 End If
38.             Next 单元格
39.         End If
40.     Next 区域索引
42.     ' 返回最终结果
43.     来源汇总 = 匹配结果
44. End Function

复制代码

泉源汇总改进

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

1. Function 来源汇总(待匹配文本 As Range, ParamArray 检索区域() As Variant) As String
2.     Dim 匹配结果 As String
3.     Dim 区域 As Variant
4.     Dim 工作表 As Worksheet
5.     Dim 单元格 As Range
6.     Dim 匹配地址 As String
7.     Dim 区域索引 As Long
8.     Dim 关键词() As Variant
9.     Dim 上级数组() As Boolean
10.     Dim 下级数组() As Collection
11.     Dim i As Long, j As Long
13.     ' 检查待匹配文本是否为空
14.     If IsEmpty(待匹配文本.Value) Or Trim(待匹配文本.Value) = "" Then
15.         来源汇总 = "----"
16.         Exit Function
17.     End If
19.     ' 初始化匹配结果
20.     匹配结果 = ""
22.     ' 获取所有关键词并初始化上级和下级数组
23.     ReDim 关键词(1 To 1)
24.     ReDim 上级数组(1 To 1)
25.     ReDim 下级数组(1 To 1)
26.     Set 下级数组(1) = New Collection
28.     ' 遍历所有指定的检索区域
29.     For 区域索引 = LBound(检索区域) To UBound(检索区域)
30.         ' 检查当前区域是否为空
31.         If Not IsEmpty(检索区域(区域索引)) Then
32.             ' 获取区域所在的工作表
33.             Set 工作表 = 检索区域(区域索引).Parent
35.             ' 遍历工作表中的每个单元格（仅在已使用的范围内）
36.             For Each 单元格 In 工作表.UsedRange
37.                 ' 检查单元格是否包含待匹配文本
38.                 If InStr(1, 单元格.Value, 待匹配文本.Value, vbTextCompare) > 0 Then
39.                     ' 构造匹配地址
40.                     匹配地址 = 工作表.Name & "!" & 单元格.Address(False, False)
42.                     ' 检查是否为上级关键词
43.                     If Not 上级数组(i) Then
44.                         ' 添加匹配地址到结果
45.                         If 匹配结果 = "" Then
46.                             匹配结果 = 匹配地址
47.                         Else
48.                             匹配结果 = 匹配结果 & "," & 匹配地址
49.                         End If
50.                     Else
51.                         ' 检查下级关键词是否匹配成功
52.                         Dim 下级关键词匹配成功 As Boolean
53.                         下级关键词匹配成功 = False
54.                         Dim 下级关键词 As Variant
55.                         For Each 下级关键词 In 下级数组(i)
56.                             If InStr(1, 单元格.Value, 下级关键词, vbTextCompare) > 0 Then
57.                                 下级关键词匹配成功 = True
58.                                 Exit For
59.                             End If
60.                         Next 下级关键词
61.                         ' 如果没有下级关键词匹配成功，则添加当前上级关键词
62.                         If Not 下级关键词匹配成功 Then
63.                             If 匹配结果 = "" Then
64.                                 匹配结果 = 匹配地址
65.                             Else
66.                                 匹配结果 = 匹配结果 & "," & 匹配地址
67.                             End If
68.                         End If
69.                     End If
70.                 End If
71.             Next 单元格
72.         End If
73.     Next 区域索引
75.     ' 返回最终结果
76.     来源汇总 = 匹配结果
77. End Function

复制代码

END


免责声明：如果侵犯了您的权益，请联系站长，我们会及时删除侵权内容，谢谢合作！更多信息从访问主页：qidao123.com:ToB企服之家，中国第一个企服评测及商务社交产业平台。

---

欢迎光临 IT评测·应用市场-qidao123.com (https://dis.qidao123.com/)

Powered by Discuz! X3.4