巧用VBA实现：基于多个关键词模糊匹配Excel多行数据

　　在用Excel处理实际业务中，我们会碰到如下场景：

　　1、从一堆人名中找到包含某些关键字的名字；

　　2、从银行流水文件中根据【备注】字段找到包含某些关键字的，统一识别为【手续费业务】等。

　　这本质说的都是一类问题：如何从数据集中，根据业务需求配置的多个关键字，匹配得到对应的行项目。这个问题有好的办法吗？

　　如果我们使用Excel自带的【自定义自动筛选】功能，它只能支持添加最多两组关键字，无法添加更多，如下图所示：

　　如果我们有多个关键词供我们作为筛选条件，Excel自带的【自定义自动筛选】功能自然不够用。假设我们的工作簿总共有三张表，【基础信息】、【姓名关键字】、【结果】表，结构如下：

 

 

 

 

 

 　　问题是，如何从【基础信息】表中找到【姓名】列 符合【姓名关键字】表中的行项目，将对应行记录在【结果】表中？

　　常规的Excel功能已经无法奏效，我们需要利用VBA手段来实现。具体思路：循环遍历【基础信息】表每一个姓名，循环取出【姓名关键字】表每个关键字，看取出的姓名是否包含这些【关键字】中的一个，如果是，就将【基础信息】表这一行信息记录在【结果】表中，这样就达到了基于多个关键字中任意一个来过滤原始数据的效果。

　　VBA示例代码如下：

Sub keyWordFilter()
Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, maxRow1 As Integer, maxRow2 As Integer, maxRow3 As Integer, userName As String, i As Integer, j As Integer, keyWord As String, k As Integer

Set sht1 = ThisWorkbook.Sheets("基础信息")
Set sht2 = ThisWorkbook.Sheets("姓名关键字")
Set sht3 = ThisWorkbook.Sheets("结果")

maxRow1 = sht1.Cells(Rows.Count, 1).End(xlUp).Row '基础信息表 行数
maxRow2 = sht2.Cells(Rows.Count, 1).End(xlUp).Row '姓名关键字表 行数
maxRow3 = sht3.Cells(Rows.Count, 1).End(xlUp).Row '结果表 行数
sht3.Rows("2:" & maxRow3).ClearContents '清空【结果表】上次留存结果，保留抬头行
k = 2
For i = 2 To maxRow1
    userName = sht1.Cells(i, 2).Value
    For j = 2 To maxRow2
        keyWord = sht2.Cells(j, 1).Value
        If userName Like "*" & keyWord & "*" Then '判断某个姓名是否包含某个关键字
            sht3.Range("A"& k & ":C" & k).Value = sht1.Range("A"& i & ":C" & i).Value 
 　　　　　　 k = k + 1 
　　　　　　　Exit For 
　　　　　End If
 　　Next 
Next 
End Sub

最后代码执行的效果，如下图所示，非常方便：

 

 

欢迎扫码关注我的公众号 获取更多爬虫、数据分析的知识！