一键提取多个表的时间范围的数据

王子宇

我想收集多个工作薄，多个表的数据，表的名称为中文。样本只是个参考。提取的文件表在同一个文件夹下执行。

孙旭白

请试一下代码

孙旭白

Sub 提取数据()
Dim arr, brr()
Dim s1 As Date, s2 As Date
s1 = Sheets("提取").Range("b1")
s2 = Sheets("提取").Range("b2")
ThisWorkbook.Sheets("提取").Range("a5:e10000").ClearContents
Dim wb As Workbook
Dim sht As Worksheet
Dim myname, mypath
mypath = ThisWorkbook.Path & "/"
myname = Dir(mypath)
Application.ScreenUpdating = False
Do While myname <> ""
    If myname <> "提取数据.xls" Then
        Set wb = Workbooks.Open(mypath & myname)
            For Each sht In wb.Worksheets
                If Not IsEmpty(sht.UsedRange) Then
                    arr = sht.UsedRange
                    For i = 2 To UBound(arr)
                        If arr(i, 2) > s1 And arr(i, 2) < s2 Then
                            m = m + 1
                            ReDim Preserve brr(1 To 5, 1 To m)
                            brr(1, m) = arr(i, 1)
                            brr(2, m) = arr(i, 2)
                            brr(5, m) = wb.Name & sht.Name
                        End If
                    Next
                End If
            Next
        wb.Close
    End If
    myname = Dir
Loop
Application.ScreenUpdating = True
ThisWorkbook.Sheets("提取").Range("a5").Resize(m, 5) = Application.Transpose(brr)
Erase brr
End Sub

王子宇

孙旭白 发表于 2019-12-27 10:33
Sub 提取数据()
Dim arr, brr()
Dim s1 As Date, s2 As Date

谢谢，就是这样效果

王子宇

孙旭白 发表于 2019-12-27 10:33
Sub 提取数据()
Dim arr, brr()
Dim s1 As Date, s2 As Date

=LOOKUP(,0/(E2=M:M),L:L)
用这个公式套数据帮多老死机，帮我换成代码一下，谢谢。
当E列的值等于M列时，显示L列的值，否侧为空

孙旭白

王子宇 发表于 2019-12-27 15:13
=LOOKUP(,0/(E2=M:M),L:L)
用这个公式套数据帮多老死机，帮我换成代码一下，谢谢。
当E列的值等于M列时 ...

给个工作表的模拟数据

donghui2363

Sub 提取数据()
t = Timer
    Dim cnn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rs1 As New ADODB.Recordset
    t1 = [b1]: t2 = [b2]
    Range("a5:e10000").ClearContents
    mypath = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
    Do While mypath <> ""
        cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.Path & "\" & mypath
        Set rs = cnn.OpenSchema(20)
        r = Range("a65536").End(xlUp).Row + 1
        Do Until rs.EOF
            If rs.Fields("TABLE_TYPE") = "TABLE" Then
                If Right(Replace(rs("TABLE_NAME").Value, "'", ""), 1) = "$" Then
                    s = rs("TABLE_NAME").Value
                    Sql = "select * from [" & s & "] where 投料日期 between # " & t1 & " #  and # " & t2 & " # "
                    m = m & "union all " & Sql
                    h = Mid(m, 11, Len(m) - 11)
                End If
                rs.MoveNext
            End If
        Loop
        On Error Resume Next
        rs1.Open h, cnn, 1, 3
        If rs1.Fields.Count > 1 Then
            Cells(r, 5) = mypath & "工作簿"
            Range("a" & r).CopyFromRecordset rs1
        End If
            h = "": m = "": Sql = ""
        rs1.Close
        mypath = Dir
        rs.Close
        cnn.Close
    Loop
    MsgBox "提取完成，用时：" & Timer - t & "秒"
    End Sub

王子宇

孙旭白 发表于 2019-12-27 15:38
给个工作表的模拟数据

请看附件，公式列就代码