20170813xlVBA跨表筛选数据

一、数组方案

Sub CustomFilter()
    Dim Rng As Range, Arr As Variant
    Dim EndRow As Long, EndCol As Long
    Dim i As Long, j As Long
    Dim n As Long
    Dim StartDate, EndDate
    Dim BeginTime, EndTime
    Dim Brr() As String

    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer

    '获取原始数据
    With Sheets("原始数据")
        '获取A列最后一行（非空行）的行号
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        '获取第一行最后一列（非空列）的列号
        EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
        '保存数据
        Set Rng = .Range(.Cells(2, 1), .Cells(EndRow, EndCol))
        'Debug.Print Rng.Address
        '存入数组
        Arr = Rng.Value
    End With

    '获取时间设定
    With Sheets("筛选设定")
        StartDate = .Range("A2").Text
        EndDate = .Range("B2").Text
        BeginTime = .Range("A4").Text
        EndTime = .Range("B4").Text
    End With

    '循环筛选符合条件的数据
    '重新声明数组，用于保存筛选出来的数据
    ReDim Brr(1 To EndCol, 1 To 1)
    '初始化筛选结果的数量
    n = 0
    For i = LBound(Arr) To UBound(Arr)
        If DateDiff("d", CDate(StartDate), CDate(Arr(i, 1))) >= 0 And _
           DateDiff("d", CDate(Arr(i, 1)), CDate(EndDate)) >= 0 And _
           Arr(i, 2) >= TimeValue(BeginTime) And _
           Arr(i, 2) <= TimeValue(EndTime) Then
            '时间在 Arr=Rng.Value的时候已经自动转为TimeValue
            n = n + 1
            ReDim Preserve Brr(1 To EndCol, 1 To n)
            For j = 1 To EndCol
                Brr(j, n) = Arr(i, j)
            Next j
        End If
    Next i

    '输出结果
    With Sheets("筛选数据")
        '清除首行标题以外的内容
        .UsedRange.Offset(1).ClearContents
        '设置筛选数据的输出区域
        Set Rng = .Range("A2")
        Set Rng = Rng.Resize(UBound(Brr, 2), UBound(Brr))
        '输出筛选结果
        Rng.Value = Application.WorksheetFunction.Transpose(Brr)
    End With

    Set Rng = Nothing

    UsedTime = VBA.Timer - StartTime
    MsgBox "本次运行耗时：" & Format(UsedTime, "#0.0000秒")

End Sub

　二、SQL方案

Sub ADO_SQL_QUERY_LOOP()
    Dim StartTime As Variant
    Dim UsedTime As Variant
    StartTime = VBA.Timer
    
    '变量声明
    Dim Wb As Workbook
    Dim ResultSht As Worksheet
    Dim DataSht As Worksheet
    Dim Rng As Range
    Dim DataPath As String
    Dim SQL As String
    Dim StartDate, EndDate
    Dim BeginTime, EndTime
    Dim CNN As Object
    Dim RS As Object
    Dim DATA_ENGINE As String
    
    '实例化对象
    Set Wb = Application.ThisWorkbook
    DataPath = Wb.FullName
    
    Set DataSht = Wb.Worksheets("原始数据")
    Set ResultSht = Wb.Worksheets("筛选数据")

    '获取时间设定
    With Wb.Worksheets("筛选设定")
        StartDate = .Range("A2").Text
        EndDate = .Range("B2").Text
        BeginTime = .Range("A4").Text
        EndTime = .Range("B4").Text
    End With
    
    '根据版本设置连接字符串
    Select Case Application.Version * 1
    Case Is <= 11
        DATA_ENGINE = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source="
    Case Is >= 12
        DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "
    End Select
    
    '创建ADO Connection 连接器 实例
    Set CNN = CreateObject("ADODB.Connection")
    '创建 ADO RecordSet  记录集 实例
    Set RS = CreateObject("ADODB.RecordSet")
    '连接数据源
    CNN.Open DATA_ENGINE & DataPath
    
    With ResultSht
        '清除首行标题以外的内容
        .UsedRange.Offset(1).ClearContents
        EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
        '设置输出结果区域
        Set Rng = .Range("A2")
        '设置查询语句
        SQL = "SELECT * FROM [" & DataSht.Name & "$A1:Z] WHERE 日期 BETWEEN #" & StartDate & "# AND #" & EndDate & "# AND " & _
        " 时间 BETWEEN #" & BeginTime & "# AND #" & EndTime & "#"
        Debug.Print SQL
        '执行查询 返回记录集
        Set RS = CNN.Execute(SQL)
        '复制记录集到指定Range
        Rng.CopyFromRecordset RS
    End With
    
    '关闭记录集
    RS.Close
    '关闭连接器
    CNN.Close
    
    Set RS = Nothing
    Set CNN = Nothing
    Set Wb = Nothing
    Set DataSht = Nothing
    Set ResultSht = Nothing
    Set Rng = Nothing
    
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次运行耗时：" & Format(UsedTime, "#0.0000秒")
    
End Sub