历遍工作表查询的问题

谢玉红

附件 历遍工作表查询附件.rar (417.17 KB, 下载次数: 15)

2020-2-21 14:52 上传

点击文件名下载附件

谢谢老师！

海好呀

仅供参考：处理前请备份，谢谢！

liulang0808

1. Sub 按钮1_Click()
   
2.     Dim arr(1 To 100000, 1 To 3)
   
3.     r = 0
   
4.     e = [E1].Value
   
5.     Application.ScreenUpdating = False
   
6.     For Each sht In Sheets
   
7.         x = sht.Cells(Rows.Count, 4).End(3).Row
   
8.         brr = sht.[d1].Resize(x + 1)
   
9.         For j = 1 To x
   
10.             If brr(j, 1) = e Then
    
11.                 r = r + 1
    
12.                 arr(r, 1) = e
    
13.                 arr(r, 2) = j
    
14.                 arr(r, 3) = sht.Name
    
15.             End If
    
16.         Next j
    
17.     Next sht
    
18.     ActiveSheet.[a1].Resize(r, 3) = arr
    
19.     Application.ScreenUpdating = True
    
20. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

chxw68

1. Sub test()
   
2.   Dim r%, i%, m%
   
3.   Dim arr, brr(1 To 10000, 1 To 3)
   
4.   Dim ws As Worksheet
   
5.   With Worksheets("0")
   
6.     sz = .Range("e1")
   
7.   End With
   
8.   m = 0
   
9.   For Each ws In Worksheets
   
10.     If ws.Name <> "0" Then
    
11.       With ws
    
12.         r = .Cells(.Rows.Count, 3).End(xlUp).Row
    
13.         arr = .Range("c1:d" & r)
    
14.         For i = 1 To UBound(arr)
    
15.           If arr(i, 2) = sz Then
    
16.             m = m + 1
    
17.             brr(m, 1) = sz
    
18.             brr(m, 2) = i
    
19.             brr(m, 3) = ws.Name
    
20.           End If
    
21.         Next
    
22.       End With
    
23.     End If
    
24.   Next
    
25.   With Worksheets("0")
    
26.     .Range("a1:c" & .Rows.Count).Clear
    
27.     .Range("a1").Resize(m, UBound(brr, 2)) = brr
    
28.   End With
    
29. End Sub
    

复制代码

chxw68

在E1单元格输入数值按回车后自动执行代码。