excle解决文本匹配大量关键字

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("Sheet1")
Set sht2 = ThisWorkbook.Sheets("Sheet2")
Set sht3 = ThisWorkbook.Sheets("Sheet3")
'基础信息表 行数
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.Cells(k, 1).Value = sht1.Cells(i, 1).Value
sht3.Cells(k, 2).Value = sht1.Cells(i, 2).Value
sht3.Cells(k, 3).Value = sht1.Cells(i, 3).Value
k = k + 1
Exit For
End If
Next
Next

End Sub