根据条件查找数据的问题

yuliangexcel

根据条件查找符合要求的数据，具体见附件。请解决，谢谢。

zhaogang1960

数据源只有9列，查询要求10列，请说明这10列分别是什么？

yuliangexcel

这10列都是强度值

zhaogang1960

请测试
Private Sub CommandButton1_Click()
    Dim cnn As Object, rs As Object, SQL$, arr(), i&, j&, m&
    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 [Sheet1$" & Sheets("Sheet1").[a1].CurrentRegion.Address(0, 0) & "] where 配合比编号='" & [N4] & "' and 供货时间 between #" & [N5] & "# and #" & [R5] & "#"
    Set rs = CreateObject("adodb.Recordset")
    rs.Open SQL, cnn, 1, 3
    ReDim arr(1 To rs.RecordCount, 1 To 20)
    For i = 1 To rs.RecordCount
        m = Int((i - 1) / 10) + 1
        j = i Mod 10
        If j = 0 Then j = 10
        arr(m, (j - 1) * 2 + 1) = rs.Fields(0).Value
        rs.MoveNext
    Next
    cnn.Close
    Set cnn = Nothing
    ActiveSheet.UsedRange.Offset(15).ClearContents
    [a16].Resize(m, 20) = arr
End Sub

zhaogang1960

请看附件
新建 Microsoft Excel 工作表.rar (52.5 KB, 下载次数: 68)

2011-7-31 12:51 上传

点击文件名下载附件

yuliangexcel

谢谢你了，我先测试一下。

yuliangexcel

当查询条件在数据源中不存在时，提示下标越界，版主再给改一下。

zhaogang1960

原帖由 yuliangexcel 于 2011-7-31 18:14 发表
当查询条件在数据源中不存在时，提示下标越界，版主再给改一下。

Private Sub CommandButton1_Click()
    Dim cnn As Object, rs As Object, SQL$, arr(), i&, j&, m&
    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 [Sheet1$" & Sheets("Sheet1").[a1].CurrentRegion.Address(0, 0) & "] where 配合比编号='" & [N4] & "' and 供货时间 between #" & [N5] & "# and #" & [R5] & "#"
    Set rs = CreateObject("adodb.Recordset")
    rs.Open SQL, cnn, 1, 3
    ActiveSheet.UsedRange.Offset(15).ClearContents
    If rs.RecordCount > 0 Then
        ReDim arr(1 To rs.RecordCount, 1 To 20)
        For i = 1 To rs.RecordCount
            m = Int((i - 1) / 10) + 1
            j = i Mod 10
            If j = 0 Then j = 10
            arr(m, (j - 1) * 2 + 1) = rs.Fields(0).Value
            rs.MoveNext
        Next
        [a16].Resize(m, 20) = arr
    Else
        MsgBox "没有查到", vbInformation
    End If
    cnn.Close
    Set cnn = Nothing
End Sub

yuliangexcel

谢谢了， 。

LMY123

SQL强度评定

补充内容 (2018-7-28 17:41):
Sub ADO批量评定复习()
    Set cnn = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.Recordset")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Fo...