[已解决]Excel VBA 多条件查找数据

love_liwu

样本.rar (18.77 KB, 下载次数: 44)

2014-10-22 09:11 上传

点击文件名下载附件

老师，您好，在进行多条件查找数据，输入以下代码，提示“至少一个参数没有被指定值”，这是怎么回事呢？恳请老师的解答！

Option Explicit
Private Sub CommandButton1_Click()
    'Dim CNN As New ADODB.Connection
    'Dim RST As New ADODB.Recordset
    Dim CNN, strsql$, RST, aa, HH, BB, CC, JJ, KK
    Set CNN = CreateObject("adodb.connection")
    Set RST = CreateObject("adodb.Recordset")
    'Dim strsql$
    Dim i&, t&
    Application.ScreenUpdating = False
    t = Sheet1.Range("A65536").End(xlUp).Row
    CNN.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
    strsql = "select 姓名,班级,学号,入学年月,性别,喜好,数据1,数据2 FROM [数据表$A2:H" & t & "] "
    RST.CursorLocation = 3
    RST.Open strsql, CNN, 3, 3
    If Sheet1.[K3] <> "" Then
        aa = " and 班级 like '*" & Sheet1.[K3] & "*'"
    End If
    If Sheet1.[K4] <> "" Then
        HH = " AND 学号 like '*" & Sheet1.[K4] & "*'"
    End If
    If Sheet1.[K5] <> "" Then
        BB = " AND 入学年月 like '*" & Sheet1.[K5] & "*'"
    End If
    If Sheet1.[K6] <> "" Then
        CC = " AND 性别 like '*" & Sheet1.[K6] & "*'"
    End If
    JJ = aa & BB & HH & CC
    KK = Mid(JJ, 6, 888)
    RST.Filter = KK
    Sheet1.Range("A2").CurrentRegion.ClearContents
    Sheet1.[A2].CopyFromRecordset RST
    RST.Close
    Set RST = Nothing: Set CNN = Nothing
    Application.ScreenUpdating = True

End Sub

在附件中，需要实现这样的目标：

首先我设置了用“高级筛选”选择了唯一的值，然后作为数据有效性作为多条件选项，当我选定之后点击“查询”，如果符合条件的，即显示，当所选选项为空白的时候，则全部显示数据表的内容。
另外，发现在打开时，运行宏代码，也会在sheet1表和sheet2表进行，我只想在sheet2表进行就可以了，怎么设置？请问如何实现，感谢！

最佳答案

月排行榜 / 总排行榜

xdragon

2014-10-22 13:28

1. Private Sub CommandButton1_Click()
   
2.     Dim CNN, strsql$, aa, HH, BB, CC, JJ, KK, DD
   
3.     Set CNN = CreateObject("adodb.connection")
   
4.     Dim i&, t&
   
5.     Application.ScreenUpdating = False
   
6.     t = Sheet1.Range("A65536").End(xlUp).Row
   
7.     CNN.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
   
8.     If Sheet1.[K3] <> "" Then
   
9.         aa = " and 班级 like '%" & Sheet1.[K3] & "%'"
   
10.     End If
    
11.     If Sheet1.[K4] <> "" Then
    
12.         HH = " AND 学号 like '%" & Sheet1.[K4] & "%'"
    
13.     End If
    
14.     If Sheet1.[K5] <> "" Then
    
15.         BB = " AND 入学年月 like '%" & Sheet1.[K5] & "%'"
    
16.     End If
    
17.     If Sheet1.[K6] <> "" Then
    
18.         CC = " AND 性别 like '%" & Sheet1.[K6] & "%'"
    
19.     End If
    
20.     If Sheet1.[K7] <> "" Then
    
21.         DD = " AND 喜好 like '%" & Sheet1.[K7] & "%'"
    
22.     End If
    
23.     JJ = aa & BB & HH & CC & DD
    
24.     If Len(JJ) Then KK = "WHERE " & Mid(JJ, 6, 888)
    
25.     strsql = "select 姓名,班级,学号,入学年月,性别,喜好,数据1,数据2 FROM [数据表$A:H] " & KK
    
26.     Sheet1.Range("A2").CurrentRegion.ClearContents
    
27.     Sheet1.Range("A1:H1") = Sheet2.Range("A1:H1").Value
    
28.     Sheet1.[A2].CopyFromRecordset CNN.Execute(strsql)
    
29.     CNN.Close
    
30.     Set CNN = Nothing
    
31.     Application.ScreenUpdating = True
    
32. End Sub

复制代码

查询的我已经更改了。你看下。。
至于你的selectchange如果运行是你要的结果的话应该没问题,我也试过貌似没看出问题来

跳转到最佳答案楼层

xdragon

由于都做了改动，你看看行不

love_liwu

xdragon 发表于 2014-10-22 09:56
由于都做了改动，你看看行不

您好，感谢老师的解答，但是不是我想要的结果：
我想实现的目标：
首先sheet2是数据源，sheet1是查询界面的工作表，在sheet1中有5个条件选项，这些选项条件是根据sheet2表来的，具有唯一性，比如说班级对应的101等（具有唯一性，我就想到通过高级筛选宏代码实现），当这些条件为空的时候，点击“查询”即将sheet2中的数据复制到sheet1表中，当不为空时候，筛选出符合条件的放到sheet1表对应的单元格中。
不知道我陈述清楚了没有？恳请您的解答。

xdragon

其实你想要的是将辅助列的内容做数据有效性的更新吧？已经更新了附件，你看看对不对吧

love_liwu

xdragon 发表于 2014-10-22 11:08
其实你想要的是将辅助列的内容做数据有效性的更新吧？已经更新了附件，你看看对不对吧

大致是这样的了，谢谢老师的热情解答，数据出错：

班级	101
学号	1
入学年月	201401
性别	女
喜好	1

得到答案：

姓名	班级	学号	入学年月	性别	喜好	数据1	数据2
张三	101	1	201401	男	1

另外我想加多这样的语句，不知道对不对：'判断当在A2：H区域数值变化的时候触发宏

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ChgArea As Range
    Dim ChgCell As Range
    Dim ChgAdd As String
    Set ChgArea = Range("A2:H10000")
    For Each ChgCell In ChgArea
        ChgAdd = ChgCell.Address
        If Target.Address = ChgAdd Then
            'MsgBox "注意：内容有变化，请确认标签是否正确！", vbExclamation
        Dim sht As Worksheet
        Set sht = ActiveSheet
        Application.ScreenUpdating = False
          Call 高级筛选—姓名
          Call 高级筛选—班级
          Call 高级筛选—学号
          Call 高级筛选—入学年月
          Call 高级筛选—性别
          Call 高级筛选—喜好
          Call 高级筛选—数据1
          Call 高级筛选—数据2
        Application.ScreenUpdating = True
        End If
    Next
End Sub

xdragon

1. Private Sub CommandButton1_Click()
   
2.     Dim CNN, strsql$, aa, HH, BB, CC, JJ, KK, DD
   
3.     Set CNN = CreateObject("adodb.connection")
   
4.     Dim i&, t&
   
5.     Application.ScreenUpdating = False
   
6.     t = Sheet1.Range("A65536").End(xlUp).Row
   
7.     CNN.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
   
8.     If Sheet1.[K3] <> "" Then
   
9.         aa = " and 班级 like '%" & Sheet1.[K3] & "%'"
   
10.     End If
    
11.     If Sheet1.[K4] <> "" Then
    
12.         HH = " AND 学号 like '%" & Sheet1.[K4] & "%'"
    
13.     End If
    
14.     If Sheet1.[K5] <> "" Then
    
15.         BB = " AND 入学年月 like '%" & Sheet1.[K5] & "%'"
    
16.     End If
    
17.     If Sheet1.[K6] <> "" Then
    
18.         CC = " AND 性别 like '%" & Sheet1.[K6] & "%'"
    
19.     End If
    
20.     If Sheet1.[K7] <> "" Then
    
21.         DD = " AND 喜好 like '%" & Sheet1.[K7] & "%'"
    
22.     End If
    
23.     JJ = aa & BB & HH & CC & DD
    
24.     If Len(JJ) Then KK = "WHERE " & Mid(JJ, 6, 888)
    
25.     strsql = "select 姓名,班级,学号,入学年月,性别,喜好,数据1,数据2 FROM [数据表$A:H] " & KK
    
26.     Sheet1.Range("A2").CurrentRegion.ClearContents
    
27.     Sheet1.Range("A1:H1") = Sheet2.Range("A1:H1").Value
    
28.     Sheet1.[A2].CopyFromRecordset CNN.Execute(strsql)
    
29.     CNN.Close
    
30.     Set CNN = Nothing
    
31.     Application.ScreenUpdating = True
    
32. End Sub

复制代码

查询的我已经更改了。你看下。。
至于你的selectchange如果运行是你要的结果的话应该没问题,我也试过貌似没看出问题来

love_liwu

xdragon 发表于 2014-10-22 13:28
查询的我已经更改了。你看下。。
至于你的selectchange如果运行是你要的结果的话应该没问题,我也试过貌似没 ...

谢谢老师，您真的很厉害。其实发现编程不是一件容易的事情。