关于多表格筛选问题

bajifeng

rio123 发表于 2015-12-21 08:17
还没有呢，还得麻烦您帮忙一下，另外，能否在关键提取数据的语句做下备注，说明该语句的作用，非常感谢！ ...

恩，好的，既然没有解决，我就帮你写下代码，虽然看上去只是减少了关键字的检索，但其实是两套完全不一样的代码。

bajifeng

rio123 发表于 2015-12-21 08:19
不好意思，1楼只在说明里面提了下，在图片上的备注中忘记备注了。

恩，说的越清楚，朋友们帮你写的代码也越精准。

rio123

bajifeng 发表于 2015-12-21 08:26
恩，好的，既然没有解决，我就帮你写下代码，虽然看上去只是减少了关键字的检索，但其实是两套完全不一样 ...

嗯嗯 ，麻烦您啦！！！！

bajifeng

1. Sub bjf()    'bajifeng
   
2. Dim brr()
   
3. s = [a2] & [b2] & [c2]
   
4. Sheets(1).UsedRange.Offset(4).Clear
   
5. For Each sh In Sheets
   
6.     i = 0
   
7.     If InStr(sh.Name, "筛") = 0 Then
   
8.         sh.Activate
   
9.         lr = sh.[a65536].End(3).Row
   
10.         arr = sh.Range([a2], Cells(lr, "g"))
    
11.         For i = 1 To UBound(arr)
    
12.             If InStr(arr(i, 1) & arr(i, 2) & arr(i, 4), s) > 0 Then
    
13.                 n = n + 1
    
14.                 ReDim Preserve brr(1 To 7, 1 To n)
    
15.                 For j = 1 To 7
    
16.                     brr(j, n) = arr(i, j)
    
17.                 Next
    
18.             End If
    
19.         Next
    
20.     End If
    
21. Next
    
22. Sheets(1).Activate
    
23. [a5:g5].Resize(UBound(brr, 2)) = Application.Transpose(brr)
    
24. End Sub

复制代码

bajifeng

>>>>>>>>>>>>>>>>>>

bajifeng

>>>>>>>>>>>
请测试附件，如有问题请回复。

xcc324919

看了gbgbxgb老师的图片感觉很有趣，不知道gbgbxgb是如何实现了，自己模拟了一个，基本上能到到gbgbxgb老师的功能，随意添加查询字段。献上附件仅供参考。烦请多提些建议。小白一个还请见谅，因为不知道如何将数据库数据放入数组，所以还是先用SQL提取所有数据出来再用另一个SQL来进行条件提取。查询字段可以随意添加要查询的东西，如年龄，工资级别等。烦请有优化方案的多多提出，让我等学习下、谢谢！
Sub tq()
Sheet1.[a5:g65536].ClearContents
Sheet1.[ad1:aj65536].ClearContents
Dim arr, b, brr, a, x
arr = Sheet1.[a1:g2]
For a = 1 To 7
If arr(1, a) = "" Then
arr(1, a) = "'%'"
End If
If arr(2, a) = "" Then
arr(2, a) = "%"
End If
If arr(2, a) <> "" Then
arr(2, a) = "'" & arr(2, a) & "'"
End If

Next

Dim rs As Object, i As Long
Set Conn = CreateObject("ADODB.Connection")                                                     '''''设置
PathStr = ThisWorkbook.FullName                                                                '''''要引用工作表位置
Conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr  ''''''打开连接
strSQL = "select * from [A公司$a1:bz] union all select * from [B公司$a1:bz] union all select * from [C公司$a1:bz] union all select * from [D公司$a1:bz]"  ''''升序使用 asc ，降序使用desc
Set rs = Conn.Execute(strSQL)
For i = 0 To rs.fields.Count - 1
Sheet1.Cells(1, i + 30) = rs.fields(i).Name
Next
Sheet1.[AD2].CopyFromRecordset Conn.Execute(strSQL)
Conn.Close
Set cnn = CreateObject("adodb.connection")
cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Sql = "select * from [筛选结果$ad1:aj] where " & arr(1, 1) & " like" + arr(2, 1) + "" & " and " & arr(1, 2) & " like " + arr(2, 2) + "" & " and " & arr(1, 3) & " like " + arr(2, 3) + "" & " and " & arr(1, 4) & " like " + arr(2, 4) + "" & " and " & arr(1, 5) & " like " + arr(2, 5) + "" & " and " & arr(1, 6) & " like " + arr(2, 6) + "" & " and " & arr(1, 7) & " like " + arr(2, 7) + ""
Sheet1.[a5].CopyFromRecordset cnn.Execute(Sql)
cnn.Close

End Sub
后面空白处还可以加入其它想进行筛选的字段来进行筛选

rio123

bajifeng 发表于 2015-12-21 08:54
>>>>>>>>>>>
请测试附件，觉得好用，送朵红花（本楼右下角->评分），如有问题请回复。

谢谢，在执行时，“公司名称”+“性别”组合查询时会报错，麻烦帮忙调试一下，谢谢：

rio123

bajifeng 发表于 2015-12-21 08:54
>>>>>>>>>>>
请测试附件，觉得好用，送朵红花（本楼右下角->评分），如有问题请回复。

另外，能否在关键语句后面给个备注，以后类似表格好自己更改，非常感谢

bajifeng

rio123 发表于 2015-12-21 10:28
谢谢，在执行时，“公司名称”+“性别”组合查询时会报错，麻烦帮忙调试一下，谢谢：

恩，好的，明白了，知道你的要求了。