批量查询某行组数据的问题

杨小妹

附件 查询行数据附件.rar (103.2 KB, 下载次数: 29)

2023-6-9 08:17 上传

点击文件名下载附件

谢谢老师！
需要读取海量数据，运行时间四个半小时。

ZHLK

Sub demo()
Dim conn As Object
Dim filename As String

For i = 1 To 2
    Sheets("表" & i).Cells.ClearContents
    filename = Dir(ThisWorkbook.Path & "\*.xlsb")
    n = 2
    Do Until filename = ""
        Set conn = CreateObject("adodb.connection")  '（1）设置对象
        conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties='excel 12.0;xml;hdr=no;';data source=" & ThisWorkbook.Path & "\" & filename
        Sql = "select *  from [sheet1$] where f1=" & Cells(i, 6) & "and f2=" & Cells(i, 7)
        Sheets("表" & i).[a65536].End(xlUp).Offset(1, 0).CopyFromRecordset conn.Execute(Sql)
        For j = n To Sheets("表" & i).[a65536].End(xlUp).Row
            Sheets("表" & i).Cells(j, 4) = filename
        Next j
    filename = Dir
    conn.Close       '关闭链接
    Set conn = Nothing  '释放对象变量
    n = Sheets("表" & i).[a65536].End(xlUp).Row
    Loop
   
Next i


End Sub


加行号确实想不出来了，除非在原表中设置有行号。数据肯定是能查出来了

半百

请测试。。。。。

yynrzwh

学习vba.,,,

zpy2

如果需要多次查询，建议还是导入数据库

ZHLK

Private Sub CommandButton1_Click()
Dim mybook As Workbook
Dim FILENAME As String
Dim arr
Application.ScreenUpdating = False
For i = 1 To 2
val1 = Cells(i, 1)
val2 = Cells(i, 2)
    FILENAME = Dir(ThisWorkbook.Path & "\*.xlsb")
    Do Until FILENAME = ""
    Set mybook = Workbooks.Open(FILENAME:=ThisWorkbook.Path & "\" & FILENAME)
    arr = mybook.Sheets("sheet1").UsedRange
    mybook.Close False
    a = 1
    Sheets("表" & i).Cells.ClearContents
    For j = 1 To UBound(arr)
        If arr(j, 1) = val1 And arr(j, 2) = val2 Then
            Sheets("表" & i).Cells(a, 1) = arr(j, 1)
            Sheets("表" & i).Cells(a, 2) = arr(j, 2)
            Sheets("表" & i).Cells(a, 3) = j
            Sheets("表" & i).Cells(a, 4) = FILENAME
            a = a + 1
        End If
    Next j
    FILENAME = Dir
    Loop
Next i
Application.ScreenUpdating = True

End Sub