obsidian/知识参考/电脑软件常用指令/Excel-VBA/VBA实现多个Sheet页匹配关键字并汇总.md

参考文献	https://blog.csdn.net/u010065762/article/details/80591087

打开excel，新建一个新sheet页，运行宏，在用户界面输入需要匹配的关键字，多个关键字按照英文逗号隔开，点击确认，循环sheet页进行匹配，并写入新建的sheet页，完毕后，保存到D盘下。

1. 插入一个用户界面UserFrom，加一个文本框，一个按钮。
   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

假如数据行断层或者数据列断层，则断层后的数据不被匹配到，这个大家自己改善代码，或者保证数据没有断层