历遍工作表对应列查询的问题

杨小妹

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

2024-7-26 11:37 上传

点击文件名下载附件

谢谢老师！

limonet

关键字：union + where

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Sht As Worksheet
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name <> "Sheet0" Then
        StrSQL = StrSQL & " Union All Select *,'" & Sht.Name & "' From [" & Sht.Name & "$] Where F7=" & [A1] & " And F8=" & [B1]
        End If
    Next Sht
    Range("A5").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

半百

Qs18

Sub qs()
Dim arr, i, sht As Worksheet
s = Sheet1.Range("a1").Value & Sheet1.Range("b1").Value
Dim brr(1 To 1000, 1 To 9)
For Each sht In Sheets
    If sht.Name <> "Sheet0" Then
    arr = sht.Range("a1:h" & sht.Cells(Rows.Count, "h").End(3).Row)
        For i = 1 To UBound(arr)
        If s = arr(i, 7) & arr(i, 8) Then
            m = m + 1
            For j = 1 To 8
                brr(m, j) = arr(i, j)
            Next
            brr(m, 9) = sht.Name
        End If
        Next

    End If
Next
Sheet1.Range("a5").Resize(m, 9) = brr
End Sub

Qs18

试试...........

Qs18

试试.............

ykcbf1100

参与一下。。。

ykcbf1100

重在参与。。。

1. Sub ykcbf()  '//2024.7.26
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("Sheet0")
   
4.     st = sh.[a1].Value & "|" & sh.[b1].Value
   
5.     ReDim brr(1 To 10000, 1 To 9)
   
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, 8)
    
11.                 For i = 2 To UBound(arr)
    
12.                     If arr(i, 7) & "|" & arr(i, 8) = st Then
    
13.                         m = m + 1
    
14.                         For j = 1 To UBound(arr, 2)
    
15.                             brr(m, j) = arr(i, j)
    
16.                         Next
    
17.                         brr(m, 9) = .Name
    
18.                     End If
    
19.                 Next
    
20.             End With
    
21.         End If
    
22.     Next
    
23.     With sh
    
24.         .[a5:i10000] = ""
    
25.         .[a5].Resize(m, 9) = brr
    
26.     End With
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    

复制代码

杨小妹

ykcbf1100 发表于 2024-7-26 12:50
重在参与。。。

老师你好，谢谢帮助。这个程序因事先考虑欠周，未能起到应有作用。我想把条件换成只输入B1.比如B1输入任意数 21，对准各工作表H列，凡H列是 21的那一行，全部提出来。并在后面标上工作表名称。