Excel-VBA多部门多表格模糊查找并返回值

应用场景

用知道的模糊信息，一次查找出所有符合条件的内容，并黏贴出来

知识要点

1：Worksheet.Change 事件  当用户更改工作表中的单元格，或外部链接引起单元格的更改时发生此事件。

2：Range.ClearContents 清除内容

3：lookat:=xlPart  部分查找

4：If Target.Address <> '$A$1' Then Exit Sub 规定只有当活动单元格为A1时，执行程序

Private Sub worksheet_change(ByVal Target As Range)

    On Error Resume Next

    If Target.Address <> '$A$1' Then Exit Sub  '如果活动单元格不是A1则退出程序

    Range(Rows('2:2'), Selection.End(xlDown)).ClearContents  '将第一行以外的内容清除

    Dim sht As Worksheet, arr(), i As Integer

    Dim rng As Range, mrng As Range

    Dim findstr As String

    For Each sht In Sheets             '遍历所有工作表

        If sht.Name <> '查询表' Then   '排除查询表

            Set rng = sht.UsedRange.Find(what:=Target.Text, LookIn:=xlValues, lookat:=xlPart) '开始查找

            If rng Is Nothing Then GoTo line  '如果未找到则跳转至标签line

            Set mrng = rng                    '将找到的对象赋值给另一个变量

            findstr = rng.Address

            Do

                i = i 1 '累加变量

                ReDim Preserve arr(1 To 4, 1 To i)  '重置数组变量存储空间

                arr(1, i) = sht.Name

                arr(2, i) = rng.Text

                arr(3, i) = rng.Offset(0, 1) '性别

                arr(4, i) = rng.Offset(0, 2) '电话

                Set rng = sht.UsedRange.FindNext(rng)  '查找下一个

            Loop While findstr = rng.Address       '直到查找到的单元格的地址等于第一个单元格地址时停止

        End If

line:

    Next

    [a2].Resize(i, 4) = WorksheetFunction.Transpose(arr) '将数组倒置后写入列表

End Sub

'工作表事件change用于代码所在工作表中任意单元格的值发生变化时执行指定的过程。该事件常会引起递归现象，所以在使用change事件时，通常配合

''application.enableevents=false'或者判断target是否指定单元格的方法来进行防范

'模糊查找，lookat必须使用xlpart，如果不是包含关系，而是强调第一个，可以用what:=target.text&'*'