|   |   |
|---|---|
|参考文献|[https://blog.csdn.net/u010065762/article/details/80591087](https://blog.csdn.net/u010065762/article/details/80591087)|

打开excel，新建一个新sheet页，运行宏，在用户界面输入需要匹配的关键字，多个关键字按照英文逗号隔开，点击确认，循环sheet页进行匹配，并写入新建的sheet页，完毕后，保存到D盘下。
    
1. 插入一个用户界面UserFrom，加一个文本框，一个按钮。
 ![Exported image](IMG-20260516155656774.png)   
2.确认按钮给一个click事件，全部代码实现如下：
   

Dim RowCount  
Dim SheetName
 
Private Sub ConfirmButton_Click()
 
Dim matchs As String, Arr() As String  
Dim idate   matchs = TextBox1.Text   If Not matchs = "" Then  
Arr = Split(matchs, ",")   For i = 0 To UBound(Arr)   ActiveSheet.Range("1:65536").ClearContents  
RowCount = 1   For Each workst In Worksheets  
If workst.Name \<\> ActiveSheet.Name Then  
SheetName = workst.Name  
Find (Arr(i))  
End If  
Next     
idate = Format(Now, "yyyyMMddhhmmss") & i  
Application.DisplayAlerts = False  
ActiveSheet.Copy  
ActiveWorkbook.SaveAs Filename:="D:\关键字(" & Arr(i) & ")_" & idate & ".xls"  
ActiveWorkbook.Close   Next   End If  
End Sub
 
Sub Find(ByVal key)
 
Dim dic  
Set dic = CreateObject("scripting.dictionary")   Dim n  
Dim m  
Dim destIndex   brr = Worksheets(SheetName).Range("a1").CurrentRegion.Value     
ReDim Arr(1 To UBound(brr), 1 To UBound(brr, 2))   With Worksheets(SheetName).Range("1:65536")  
Set c = .Find(key, LookIn:=xlValues)   If Not c Is Nothing Then  
firstaddress = c.Address   Do   If Not dic.Exists(c.Row) Then  
m = 1   dic(c.Row) = dic.Count + 1  
n = dic.Count   If c.Row \<= UBound(brr) Then  
For j = 1 To UBound(brr, 2)  
Arr(n, j) = brr(c.Row, j)  
Next  
End If   End If   Set c = .FindNext(c)   If c Is Nothing Then  
Exit Do  
End If   Loop While c.Address \<\> firstaddress   End If  
End With   If m \> 0 Then  
destIndex = "a" & RowCount  
ActiveSheet.Range(destIndex).Resize(dic.Count, UBound(brr, 2)).Value = Arr  
RowCount = RowCount + dic.Count   Erase Arr  
For Each key In dic.Keys  
dic.Remove key  
Next  
End If
 
End Sub  
3.有个问题需要注意
 
Worksheets(SheetName).Range("a1").CurrentRegion.Value
 
假如数据行断层或者数据列断层，则断层后的数据不被匹配到，这个大家自己改善代码，或者保证数据没有断层