一、数组方案
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