请教遍历sheets模糊查询"合并返回"不能

MR.chlive

1. Sub search()
   
2. On Error Resume Next
   
3.     'If Target.Address <> "$A$1" Then Exit Sub  '如果活动单元格不是A1则退出程序
   
4.     'Range(Rows("2:2"), Selection.End(xlDown)).ClearContents  '将第一行以外的内容清除
   
5. Dim sht As Worksheet, arr(), i As Integer
   
6. Dim rng As Range, mrng As Range, target
   
7. Dim findstr As String
   
8.     target = "无视频段"
   
9.     For Each sht In Sheets             '遍历所有工作表
   
10.         If sht.Name <> "汇总" Then     '排除查询表
    
11.             Set rng = sht.UsedRange.find(what:=target, LookIn:=xlValues, lookat:=xlPart) '开始查找
    
12.             If rng Is Nothing Then GoTo line  '如果未找到则跳转至标签line
    
13.             'Set mrng = rng                    '将找到的对象赋值给另一个变量
    
14.             findstr = rng.Address
    
15.             Do
    
16.                 i = i + 1 '累加变量
    
17.                 ReDim Preserve arr(1 To 5, 1 To i)  '重置数组变量存储空间
    
18.                 arr(1, i) = rng.Offset(rng.Row, 1 - rng.Column)  '日期
    
19.                 If rng.Offset(3 - rng.Row, -2) = "" Then    '工位名称为空判定,调整列偏移
    
20.                 arr(2, i) = rng.Offset(3 - rng.Row, -1)
    
21.                 Else
    
22.                 arr(2, i) = rng.Offset(3 - rng.Row, -2)
    
23.                 End If
    
24.                 arr(3, i) = rng.Offset(rng.Row, -1)         '断点时间
    
25.                 arr(4, i) = rng.Text                        '断点原因
    
26.                 arr(5, i) = sht.Name
    
27.                
    
28.                 Set rng = sht.UsedRange.FindNext(rng)       '查找下一个
    
29.              Loop While findstr = rng.Address     '直到查找到的单元格的地址等于第一个单元格地址时停止
    
30.             
    
31.         End If
    
32. line:
    
33.     Next
    
34.     [a2].Resize(i, 5) = WorksheetFunction.Transpose(arr) '将数组倒置后写入列表
    
35. End Sub

复制代码

核查表.7z (311.27 KB, 下载次数: 2)

2020-2-26 21:31 上传

点击文件名下载附件

代码如上，始终只能返回第一个工作表的匹配内容，请教这是为什么呢？可以不用字典吗？请大神看附件样板数据。