修改VBA自定义函数 实现单元格文本包含匹配并返回对应值

需求：将原精确匹配的查找函数修改为模糊匹配——当原表格「Companies」列的单元格内容包含新表格中的公司名称时，把原表格对应行的姓名提取至新表格「Employees」列，结果以逗号分隔的CSV格式返回。

原精确匹配函数代码 #

Option Explicit
Function LookupCSVResults(lookupValue As Variant, lookupRange As Range, resultsRange As Range) As String

    Dim s As String '结果存储变量
    Dim sTmp As String  '单元格临时值
    Dim r As Long   '行索引
    Dim c As Long   '列索引
    Const strDelimiter = "|||"  '用于避免重复匹配的分隔符

    s = strDelimiter
    For r = 1 To lookupRange.Rows.Count
        For c = 1 To lookupRange.Columns.Count
            '精确匹配判断
            If lookupRange.Cells(r, c).Value = lookupValue Then
 
                sTmp = resultsRange.Offset(r - 1, c - 1).Cells(1, 1).Value
                '避免重复添加相同结果
                If InStr(1, s, strDelimiter & sTmp & strDelimiter) = 0 Then
                    s = s & sTmp & strDelimiter
                End If
            End If
        Next
    Next

    '转换为CSV格式
    s = Replace(s, strDelimiter, ",")
    If Left(s, 1) = "," Then s = Mid(s, 2)
    If Right(s, 1) = "," Then s = Left(s, Len(s) - 1)

    LookupCSVResults = s
End Function

修改后的模糊匹配函数代码 #

Option Explicit
Function LookupCSVResults2(lookupValue As Variant, lookupRange As Range, resultsRange As Range) As String

    Dim s As String '结果存储变量
    Dim sTmp As String  '单元格临时值
    Dim r As Long   '行索引
    Dim c As Long   '列索引
    Const strDelimiter = "|||"  '用于避免重复匹配的分隔符

    s = strDelimiter
    For r = 1 To lookupRange.Rows.Count
        For c = 1 To lookupRange.Columns.Count
            '模糊匹配：判断查找范围单元格是否包含目标值
            If InStr(lookupRange.Cells(r, c).Value, lookupValue) > 0 Then
                sTmp = resultsRange.Offset(r - 1, c - 1).Cells(1, 1).Value
                '避免重复添加相同结果
                If InStr(1, s, strDelimiter & sTmp & strDelimiter) = 0 Then
                    s = s & sTmp & strDelimiter
                End If
            End If
        Next
    Next

    '转换为CSV格式
    s = Replace(s, strDelimiter, ",")
    If Left(s, 1) = "," Then s = Mid(s, 2)
    If Right(s, 1) = "," Then s = Left(s, Len(s) - 1)

    LookupCSVResults2 = s 
End Function

核心修改点 #

• 将原函数中的精确匹配判断If lookupRange.Cells(r, c).Value = lookupValue Then替换为If InStr(lookupRange.Cells(r, c).Value, lookupValue) > 0 Then，通过InStr函数检测单元格内容是否包含目标文本，实现模糊匹配。
• 保留了原函数的去重逻辑和CSV格式转换逻辑，确保结果无重复且格式规范。

内容的提问来源于stack exchange，提问作者freshprints