VBA单个或多个条件查询

jovelive

附件表中通过vba按月份，单据类型，单位，这三个条件中的一个条件，或两三个条件查询数据库表中的数据

请各位老师帮忙 查询.rar (79.28 KB, 下载次数: 56)

2014-12-3 18:54 上传

点击文件名下载附件

zhenghui13

请测试

1. Sub Inquire()
   
2. Dim arr()
   
3. Dim crr(), SK$, m&
   
4. Dim KEY$, i&, j&
   
5. Dim CXYF As String, DJLX As String, CXDW As String
   
6. With Sheet4
   
7. If .Cells(2, 2) <> "" Then CXYF = .Cells(2, 2).Value Else CXYF = "*"
   
8. If .Cells(2, 4) <> "" Then DJLX = .Cells(2, 4).Value Else DJLX = "*"
   
9. If .Cells(2, 6) <> "" Then CXDW = .Cells(2, 6).Value Else CXDW = "*"
   
10. arr = Sheet6.UsedRange  'Starting from 2
    
11. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
    
12. KEY = CXYF & "|" & DJLX & "|" & CXDW
    
13. For i = 3 To UBound(arr)
    
14.    SK = Month(arr(i, 1)) & "|" & arr(i, 2) & "|" & arr(i, 4)
    
15.    If SK Like KEY Then
    
16.       m = m + 1
    
17.       For j = 1 To UBound(arr, 2)
    
18.          crr(m, j) = arr(i, j)
    
19.       Next j
    
20.    End If
    
21. Next i
    
22. .Cells(4, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
    
23. End With
    
24. End Sub

复制代码

jpj123

1. Sub 条件查询()
   
2.     Dim Conn As Object, Rst As Object
   
3.     Dim strConn As String, strSQL As String
   
4.     Dim i As Integer, PathStr As String
   
5.     Set Conn = CreateObject("ADODB.Connection")
   
6.     Set Rst = CreateObject("ADODB.Recordset")
   
7.     PathStr = ThisWorkbook.FullName
   
8.     strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='excel 8.0;hdr=yes';Data source=" & PathStr
   
9.     Conn.Open strConn
   
10.     strSQL = "select * from [数据库$a2:K] where month(日期) = '" & Sheets("查询").Cells(2, "B") & "' and 收货付款 = '" & Sheets("查询").Cells(2, "D") & "' and 单位 = '" & Sheets("查询").Cells(2, "F") & "'"
    
11.     Set Rst = Conn.Execute(strSQL)
    
12.     With Sheets("查询")
    
13.         .UsedRange.Offset(3).ClearContents
    
14.         For i = 0 To Rst.Fields.Count - 1    '填写标题
    
15.             .Cells(3, i + 1) = Rst.Fields(i).Name
    
16.         Next i
    
17.         .Range("A4").CopyFromRecordset Rst
    
18.     End With
    
19.     Rst.Close    '关闭数据库连接
    
20.     Conn.Close
    
21.     Set Conn = Nothing
    
22.     Set Rst = Nothing
    
23.     Sheets("查询").Select
    
24. End Sub
    
25. 
    

复制代码

jpj123

详见附件   

jovelive

zhenghui13 发表于 2014-12-3 20:37
请测试

谢谢，可以了，非常感谢

jovelive

jpj123 发表于 2014-12-3 21:42

代码只能三个条件一起查询，不能单一个，或两个查询
很感谢你！

jpj123

jovelive 发表于 2014-12-4 09:51
代码只能三个条件一起查询，不能单一个，或两个查询
很感谢你！

1. Sub 条件查询()
   
2.     Dim Conn As Object, Rst As Object
   
3.     Dim strConn As String, strSQL As String
   
4.     Dim i As Integer, PathStr As String
   
5.     Dim A1, A2, A3
   
6.     Set Conn = CreateObject("ADODB.Connection")
   
7.     Set Rst = CreateObject("ADODB.Recordset")
   
8.     PathStr = ThisWorkbook.FullName   '设置工作簿的完整路径和名称
   
9. '--------------------------------------------------------------------------
   
10. With Sheets("查询")
    
11. If .Cells(2, 2) <> "" Then A1 = .Cells(2, 2).Value Else A1 = "%"
    
12. If .Cells(2, 4) <> "" Then A2 = .Cells(2, 4).Value Else A2 = "%"
    
13. If .Cells(2, 6) <> "" Then A3 = .Cells(2, 6).Value Else A3 = "%"
    
14. End With
    
15. '------------------------------------------------------------------------
    
16.     strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='excel 8.0;hdr=yes';Data source=" & PathStr
    
17.     Conn.Open strConn    '打开数据库链接
    
18.     strSQL = "select * from [数据库$a2:K] where month(日期) like '" & A1 & "' and 收货付款 like '" & A2 & "' and 单位 like '" & A3 & "'"
    
19.     Set Rst = Conn.Execute(strSQL)    '执行查询，并将结果输出到记录集对象
    
20.     With Sheets("查询")
    
21.         .UsedRange.Offset(3).ClearContents
    
22.         For i = 0 To Rst.Fields.Count - 1    '填写标题
    
23.             .Cells(3, i + 1) = Rst.Fields(i).Name
    
24.         Next i
    
25.         .Range("A4").CopyFromRecordset Rst
    
26.     End With
    
27.     Rst.Close    '关闭数据库连接
    
28.     Conn.Close
    
29.     Set Conn = Nothing
    
30.     Set Rst = Nothing
    
31.     Sheets("查询").Select
    
32. End Sub
    

复制代码

也可以实现模糊查询

jpj123

详见附件     

jovelive

jpj123 发表于 2014-12-4 14:14
详见附件

非常感谢你的帮忙，学习了。！！谢谢！

aliensky

jpj123 发表于 2014-12-3 22:04
详见附件

学习了，正好用到。