VBA实现多个Sheet页匹配关键字并汇总 |
您所在的位置：网站首页 › 平头哥是 › VBA实现多个Sheet页匹配关键字并汇总 |
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 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 Sub3.有个问题需要注意 Worksheets(SheetName).Range("a1").CurrentRegion.Value假如数据行断层或者数据列断层，则断层后的数据不被匹配到，这个大家自己改善代码，或者保证数据没有断层 4.OK，完毕。 |
。
【本文地址】
今日新闻 |
推荐新闻 |