使用Excel宏匹配data工作表description列与pattern工作表strmatch列子串

需求说明 #

现有包含约20000条记录的Excel文件，其中data工作表包含description列，pattern工作表包含strmatch列。需通过VBA宏实现以下功能：

• 检查data工作表description列的每个字符串，判断是否包含pattern工作表strmatch列中的任意子串
• 匹配成功时返回对应的匹配子串，无匹配时返回No Match found
• 将结果输出到data工作表的新增列中

示例数据 #

data工作表示例 #

pattern工作表示例 #

实现宏代码 #

Sub MatchPatterns()
    Dim wsData As Worksheet, wsPattern As Worksheet
    Dim lastRowData As Long, lastRowPattern As Long
    Dim i As Long, j As Long
    Dim descText As String, matchStr As String
    Dim matchFound As Boolean
    
    ' 指定工作表
    Set wsData = ThisWorkbook.Worksheets("data")
    Set wsPattern = ThisWorkbook.Worksheets("pattern")
    
    ' 获取数据最后一行（假设目标列均为A列）
    lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    lastRowPattern = wsPattern.Cells(wsPattern.Rows.Count, "A").End(xlUp).Row
    
    ' 添加结果列标题
    wsData.Cells(1, "B").Value = "匹配结果"
    
    ' 遍历data表所有记录
    For i = 2 To lastRowData
        descText = wsData.Cells(i, "A").Value
        matchFound = False
        
        ' 遍历pattern表所有匹配串
        For j = 2 To lastRowPattern
            matchStr = wsPattern.Cells(j, "A").Value
            ' 不区分大小写匹配，如需区分则替换为vbBinaryCompare
            If InStr(1, descText, matchStr, vbTextCompare) > 0 Then
                wsData.Cells(i, "B").Value = matchStr
                matchFound = True
                Exit For ' 找到第一个匹配即停止，如需多匹配可删除此行
            End If
        Next j
        
        ' 无匹配时赋值
        If Not matchFound Then
            wsData.Cells(i, "B").Value = "No Match found"
        End If
    Next i
    
    MsgBox "匹配完成！", vbInformation
End Sub

代码说明 #

• 默认description列在data表A列，strmatch列在pattern表A列，结果输出到data表B列，可根据实际列位置修改代码中的列标识（如"A"、"B"）
• InStr函数的vbTextCompare参数实现不区分大小写匹配，若需严格区分大小写，改为vbBinaryCompare即可
• 代码找到第一个匹配串后就终止遍历，若需要返回所有匹配的子串，可移除Exit For并调整结果的拼接逻辑

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