历遍工作表精准查询的问题

杨小妹

附件 历遍工作表精准查询附件.rar (361.4 KB, 下载次数: 8)

2024-7-13 09:15 上传

点击文件名下载附件

谢谢老师！

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, wks As Worksheet
   
    Application.ScreenUpdating = False
   
    ReDim ar(1 To 10 ^ 4, 1 To 6)
    With Worksheets("Sheet0")
        For Each wks In Worksheets
            If wks.Name <> .Name Then
                br = wks.UsedRange
                For i = 1 To UBound(br)
                    If br(i, 2) = .[B1].Value And br(i, 3) = .[c1].Value Then
                        r = r + 1
                        For j = 1 To UBound(br, 2)
                            ar(r, j) = br(i, j)
                        Next j
                        ar(r, 6) = wks.Name
                    End If
                Next i
            End If
        Next
        .[A3].CurrentRegion.Clear
        If r Then .[A3].Resize(r, 6) = ar
        .Activate
    End With
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

..............

feilanga

...................

feilanga

1. ................
   

复制代码

feilanga

1. Sub tq()
   
2.     b = [B1]
   
3.     C = [C1]
   
4.     Dim brr()
   
5.     Dim sht As Worksheet
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> ActiveSheet.Name Then
   
8.             arr = sht.UsedRange
   
9.             If IsArray(arr) = True Then
   
10.                 For i = 1 To UBound(arr)
    
11.                     If arr(i, 2) = b And arr(i, 3) = C Then
    
12.                         k = k + 1
    
13.                         ReDim Preserve brr(1 To 6, 1 To k)
    
14.                         For j = 1 To 5
    
15.                             brr(j, k) = arr(i, j)
    
16.                         Next
    
17.                         brr(6, k) = sht.Name
    
18.                     End If
    
19.                 Next
    
20.                 Erase arr
    
21.             End If
    
22.         End If
    
23.     Next
    
24.     ReDim temp(1 To k, 1 To 6)
    
25.     For i = 1 To k
    
26.         For j = 1 To 6
    
27.             temp(i, j) = brr(j, i)
    
28.         Next
    
29.     Next
    
30.     Range("I3:N" & Rows.Count).ClearContents
    
31.     Range("I3").Resize(k, 6) = temp
    
32. End Sub
    

复制代码

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.13
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("Sheet0")
   
4.     ReDim brr(1 To 10000, 1 To 6)
   
5.     st1 = sh.[b1]: st2 = sh.[c1]
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> sh.Name Then
   
8.             With sht
   
9.                 r = .Cells(Rows.Count, 1).End(3).Row
   
10.                 arr = .[a1].Resize(r + 1, 5)
    
11.                 For i = 1 To UBound(arr) Step 3
    
12.                     If arr(i + 1, 2) = st1 And arr(i + 1, 3) = st2 Then
    
13.                         m = m + 1
    
14.                         For j = 1 To 5
    
15.                             brr(m, j) = arr(i + 1, j)
    
16.                         Next
    
17.                         brr(m, 6) = .Name
    
18.                     End If
    
19.                 Next
    
20.             End With
    
21.         End If
    
22.     Next
    
23.     With sh
    
24.         .[a3:f10000] = ""
    
25.         .[a3].Resize(m, 6) = brr
    
26.     End With
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    
30. 
    

复制代码