VBA实现多个Sheet页匹配关键字并汇总

初次写博客，错误之处请包涵。

       用户需求：媳妇统计excel时需要在多个sheet页中搜索关键字，找到匹配的行后再粘贴到新的sheet页中，

然后问我有什么快捷的方法，一键式的。 我想了想写个宏，碎碎个事。好了，开始！

     实现思路：打开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

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

4.OK，完毕。