[已解决]多条件跨工作表查找并将满足条件数据复制到指定区域的问题？

wdqinweiyu · 发表于 2013-5-8 14:20

天啊，要一个表一个表的查找数据真累，求老师帮忙做一个能够跨工作表查找的东东，那就太感谢了！！

数据跨多个工作表查询.rar (26.51 KB, 下载次数: 316)

hwc2ycy · 发表于 2013-5-8 19:07

新插入一个模块，粘贴代码，然后按钮重新指定宏。

Const adUseClient = 3
Const adModeShareDenyWrite = 8
Const adModeReadWrite = 3
Const adModeRead = 1
Sub 查询()
Dim AdoConn As Object, AdoRst As Object
Dim StrConn$, strSQL$, strTemp$
Dim DataSource$
Dim iCondition As Byte
Dim i As Byte
Set AdoConn = CreateObject("ADODB.Connection")
Set AdoRst = CreateObject("ADODB.Recordset")
DataSource = ThisWorkbook.FullName
Select Case Application.Version
Case Is = "14.0":
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & _
DataSource & ";Extended Properties=""Excel 12.0;HDR=yes;imex=1"";"""
Case Is = "12.0"
StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & _
DataSource & ";Extended Properties=""Excel 12.0;HDR=yes;imex=1"";"""
Case Else
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & DataSource & "Extended Properties=""Excel 8.0;HDR=yes;imex=1"";"
End Select
Dim arr
arr = Range("b1:x2")
For i = LBound(arr) To UBound(arr, 2)
If Len(arr(2, i)) > 0 Then
strTemp = strTemp & arr(1, i) & " like '" & arr(2, i) & "%' and "
End If
Next
If Len(strTemp) > 0 Then strTemp = Left(strTemp, Len(strTemp) - 5)
'strTemp = Replace(strTemp, "%%", "%")
For i = 1 To 4
Select Case True
Case Len(strTemp) > 0:
strSQL = strSQL & "select * from [" & i & "$a1:y] where " & strTemp & " union all "
Case Else
strSQL = strSQL & "select * from [" & i & "$a1:y] union all "
End Select
Next
strSQL = Left(strSQL, Len(strSQL) - 10)
On Error GoTo ErrCheck
With AdoConn
.CommandTimeout = 5
.ConnectionTimeout = 5
.CursorLocation = adUseClient
.Mode = adModeRead
.ConnectionString = StrConn
.Open
End With
Set AdoRst = AdoConn.Execute(strSQL)
With Range("a5")
If Cells(Rows.Count, 1).End(xlUp).Row > 4 Then
Range("a5:x" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
End If
Application.ScreenUpdating = False
.CopyFromRecordset AdoRst
Application.ScreenUpdating = True
MsgBox "查询完成"
End With
AdoConn.Close
Exit Sub
ErrCheck:
MsgBox Err.Number & vbCrLf & _
Err.Description
Set AdoRst = Nothing
Set AdoConn = Nothing
End Sub

复制代码

hwc2ycy · 发表于 2013-5-8 19:09

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

现在通配符查找只会查找以指定内容开头的，如果要做到只要包含指定内容的话，
只需把
strTemp = strTemp & arr(1, i) & " like '" & arr(2, i) & "%' and "
改为
strTemp = strTemp & arr(1, i) & " like '%" & arr(2, i) & "%' and "

wdqinweiyu · 发表于 2013-5-16 11:10

我下来以后，粘贴时提示错误，语法错误，不知道哪里出问题，还请老师帮忙看看

wdqinweiyu · 发表于 2013-5-16 16:39

急盼，还是没用的上。

hwc2ycy · 发表于 2013-5-16 18:26

wdqinweiyu 发表于 2013-5-16 16:39
急盼，还是没用的上。

strTemp = strTemp & arr(1, i) & " like '%" & arr(2, i) & "%' and "

hwc2ycy · 发表于 2013-5-16 18:27

单引号与双引与我弄反了，

wdqinweiyu · 发表于 2013-5-17 08:37

hwc2ycy 老师，我还是上传附件你再看下，老说是语法错误。

wdqinweiyu · 发表于 2013-5-17 08:39

StrConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & _

DataSource & ";Extended Properties=""Excel 12.0;HDR=yes;imex=1"";"""
从上面这位置起，一执行就说是语法错误，变为红色。

		自动登录	找回密码
密码			注册