[已解决]两个条件改为单个的查询

amulee

写了一个过程。你自己在相应的代码里面调用这个过程吧。

Sub 人名添加()
    Dim MySht As Worksheet
    Dim d As Object
    Dim ArrRM, Temp
    Set d = CreateObject("Scripting.Dictionary")
    For Each MySht In Worksheets
        If MySht.Name <> "结果显示" And MySht.Name <> "界面" _
            And MySht.Name <> "帮助" And MySht.Name <> "引用" Then
            arrys = MySht.Range("F2:F" & MySht.Range("F65536").End(xlUp).Row)
            For Each Temp In arrys
                d(Temp) = 1
            Next
        End If
    Next
    UserForm2.ComboBox5.Clear
    UserForm2.ComboBox5.List = d.Keys
End Sub

zzk386

谢版主,行啦!

没完没了再提一个要求:原来的显示结果表中"具体名称"前插一列,标题是"物品分类",它和

具体名称的对应关系见引用表的A,B列

原因:引用表中A列中物品分类可以清楚表达物品,而B列的具体名称不一定能反映出物品,可能是一个型号,

在查询出的列表中,看到查询出的型号不一定能联想对应的具体的物品,所以有必要增加物品分类列.

zzk386

查询发现了一个新问题

 

SqmG2jqq.rar (36.07 KB, 下载次数: 0)

2010-1-28 09:07 上传

点击文件名下载附件
查询测试碰到了怪问题,请高手解决(最后一个问题还没解决呢)

amulee

由于类型问题出错，已修正
Private Sub CommandButton2_Click() '主查询按钮
    On Error Resume Next
    Sheets("结果显示").Visible = 2 '隐藏“结果显示”工作表
    Sheets("结果显示").Rows("2:65536") = "" '清空
    CommandButton4.Caption = "显示查询结果"
    '建立ADO查询
    Dim adoCN As Object, i As Integer
    Dim SQL As String, strTJ As String, Temp As String
    Dim MySht As Worksheet
    Set adoCN = CreateObject("ADODB.Connection")
    '设定SQL
    If CheckBox1.Value = True Then
        For Each MySht In Worksheets
            If MySht.Name <> "结果显示" And MySht.Name <> "界面" _
                And MySht.Name <> "帮助" And MySht.Name <> "引用" Then
                SQL = SQL & " Union all select """ & MySht.Name & """,* from [" & MySht.Name & "$]"
            End If
        Next
        SQL = Right(SQL, Len(SQL) - 11)
    Else
        If ComboBox1.Value <> "" Then
            SQL = "select " & ComboBox1.Value & ",* from [" & ComboBox1.Value & "$]"
        Else
            MsgBox "未选择表格"
            Exit Sub
        End If
    End If
    '设定条件
    For i = 3 To 5
        Temp = UserForm2.Controls("Combobox" & i).Value
        If Len(Temp) > 0 Then
            strTJ = strTJ & " and " & UserForm2.Controls("Label" & i + 2).Caption & "=""" & Temp & """"
        End If
    Next i
    '设定物品查询条件。如果没有具体名称则按照大类查找
    If Len(ComboBox3.Text) = 0 And Len(ComboBox2.Text) > 0 Then
        '查找大类
        Temp = ComboBox2.Text
        Dim stRow&, edRow&, strList
        stRow = Sheets("引用").Range("A:A").Find(Temp, Sheets("引用").Range("A2"), , , , xlNext).Row
        edRow = Sheets("引用").Range("A:A").Find("*", Sheets("引用").Range("A" & stRow), , , , xlNext).Row - 1
        If edRow < stRow Then edRow = Sheets("引用").Range("B65536").End(xlUp).Row
        strList = Join(Application.Transpose(Sheets("引用").Range("B" & stRow & ":B" & edRow)), """,""")
        strTJ = strTJ & " and 具体名称 in " & "(""" & strList & """)"
    End If
    '设定日期条件
    If CheckBox2.Value = True Then
        '两个日期都要填写
        If Len(TextBox1.Text) * Len(TextBox2.Text) > 0 Then
            strTJ = strTJ & " and 日期>=#" & TextBox1.Text & "# and 日期<=#" & TextBox2.Text & "#"
        Else
            MsgBox "日期没有填写完整"
            TextBox1.SetFocus
            Exit Sub
        End If
    End If
    '若有条件，则添加条件
    If Len(strTJ) > 0 Then
        SQL = "select * from (" & SQL & ") where " & Right(strTJ, Len(strTJ) - 5)
    End If
    '打开连接
    adoCN.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & ThisWorkbook.FullName & _
            ";Extended Properties=Excel 8.0"
    
    Sheets("结果显示").Range("A2").CopyFromRecordset adoCN.Execute(SQL)
    '关闭连接
    adoCN.Close
    '写入listbox1中,及各种显示
    Call 列表框显示
    Call 显示数值
    If Len(ComboBox3.Text) = 0 Then '如果具体名称复合框为空
        Call 各种
    Else
        Call 单位名称
    End If
End Sub

zzk386

还是有问题,

 

RHC54KJU.rar (36.74 KB, 下载次数: 0)

2010-1-28 10:14 上传

点击文件名下载附件
查询测试碰到了怪问题,请高手解决(最后一个问题还没解决呢)

amulee

QUOTE:

以下是引用zzk386在2010-1-28 10:14:00的发言：

还是有问题,

 

改过了。那个具体名称的字段你改了名称，所以会出错。
Private Sub CommandButton2_Click() '主查询按钮
    On Error Resume Next
    Sheets("结果显示").Visible = 2 '隐藏"结果显示"工作表
    Sheets("结果显示").Rows("2:65536") = "" '清空
    CommandButton4.Caption = "显示查询结果"
    '建立ADO查询
    Dim adoCN As Object, i As Integer
    Dim SQL As String, strTJ As String, Temp As String
    Dim MySht As Worksheet
    Set adoCN = CreateObject("ADODB.Connection")
    '设定SQL
    If CheckBox1.Value = True Then
        For Each MySht In Worksheets
            If MySht.Name <> "结果显示" And MySht.Name <> "界面" _
                And MySht.Name <> "帮助" And MySht.Name <> "引用" Then
                SQL = SQL & " Union all select """ & MySht.Name & """ as 项目表,* from [" & MySht.Name & "$]"
            End If
        Next
        SQL = Right(SQL, Len(SQL) - 11)
    Else
        If ComboBox1.Value <> "" Then
            SQL = "select """ & ComboBox1.Value & """ as 项目表,* from [" & ComboBox1.Value & "$]"
        Else
            MsgBox "未选择表格"
            Exit Sub
        End If
    End If
    '设定条件
    For i = 3 To 5
        Temp = UserForm2.Controls("Combobox" & i).Value
        If Len(Temp) > 0 Then
            strTJ = strTJ & " and " & UserForm2.Controls("Label" & i + 2).Caption & "=""" & Temp & """"
        End If
    Next i
    '设定物品查询条件。如果没有具体名称则按照大类查找
    If Len(ComboBox3.Text) = 0 And Len(ComboBox2.Text) > 0 Then
        '查找大类
        Temp = ComboBox2.Text
        Dim stRow&, edRow&, strList
        stRow = Sheets("引用").Range("A:A").Find(Temp, Sheets("引用").Range("A2"), , , , xlNext).Row
        edRow = Sheets("引用").Range("A:A").Find("*", Sheets("引用").Range("A" & stRow), , , , xlNext).Row - 1
        If edRow < stRow Then edRow = Sheets("引用").Range("B65536").End(xlUp).Row
        strList = Join(Application.Transpose(Sheets("引用").Range("B" & stRow & ":B" & edRow)), """,""")
        strTJ = strTJ & " and 名称和型号 in " & "(""" & strList & """)"
    End If
    '设定日期条件
    If CheckBox2.Value = True Then
        '两个日期都要填写
        If Len(TextBox1.Text) * Len(TextBox2.Text) > 0 Then
            strTJ = strTJ & " and 日期>=#" & TextBox1.Text & "# and 日期<=#" & TextBox2.Text & "#"
        Else
            MsgBox "日期没有填写完整"
            TextBox1.SetFocus
            Exit Sub
        End If
    End If
    '若有条件，则添加条件
    If Len(strTJ) > 0 Then
        SQL = "select * from (" & SQL & ") where " & Right(strTJ, Len(strTJ) - 5)
    End If
    '打开连接
    adoCN.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & ThisWorkbook.FullName & _
            ";Extended Properties=Excel 8.0"
    
    Sheets("结果显示").Range("A2").CopyFromRecordset adoCN.Execute(SQL)
    '关闭连接
    adoCN.Close
    '写入listbox1中,及各种显示
    Call 列表框显示
    Call 显示数值
    If Len(ComboBox3.Text) = 0 Then '如果具体名称复合框为空
        Call 各种
    Else
        Call 单位名称
    End If
End Sub

zzk386

还有问题:
选择工作表+物品分类+具体名称组合查,查不到数据
选日期查,终止日期的数据查不到,只能查到起始日到终止日期前一天的数据

amulee

你这里叫具体名称，窗体里面也叫具体名称。原始表格里面叫名称和型号，最好统一一个。

zzk386

还存在小问题,请看附件 MhlX1PrZ.rar (34.41 KB, 下载次数: 2)

2010-1-29 07:12 上传

点击文件名下载附件
查询测试碰到了怪问题,请高手解决(最后一个问题还没解决呢)

zzk386

QUOTE:

以下是引用amulee在2010-1-27 9:43:00的发言：

写了一个过程。你自己在相应的代码里面调用这个过程吧。

Sub 人名添加()
    Dim MySht As Worksheet
    Dim d As Object
    Dim ArrRM, Temp
    Set d = CreateObject("Scripting.Dictionary")
    For Each MySht In Worksheets
        If MySht.Name <> "结果显示" And MySht.Name <> "界面" _
            And MySht.Name <> "帮助" And MySht.Name <> "引用" Then
            arrys = MySht.Range("F2:F" & MySht.Range("F65536").End(xlUp).Row)
            For Each Temp In arrys
                d(Temp) = 1
            Next
        End If
    Next
    UserForm2.ComboBox5.Clear
    UserForm2.ComboBox5.List = d.Keys
End Sub

还有一个问题:

如果某个项目表中除表头那行以外只有一行数据,该表的经手人姓名不会出现在UserForm2.ComboBox5中,

可以这样改吗?

            arrys = MySht.Range("F2:F" & MySht.Range("F65536").End(xlUp).Row+1)
           

[此贴子已经被作者于2010-1-29 13:24:58编辑过]