VBA+SQL 多条件查询与分类汇总 (时间格式+正常参数)

需求：1、根据第一行与第二行的内容进行数据查找，查找后结果显示在本页下 2、进行简单信息汇总，找出自己要的统计信息 (灰色区域部分)

代码实现： VBA+SQL

代码如下:

Sub strSQLFindData()

Dim cnn As Object, rst As Object

Dim strPath As String, str_cnn As String, StrSQL As String

Dim i As Long, j As Long

Set cnn = CreateObject("adodb.connection")

strPath = ThisWorkbook.FullName

str_cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes;IMEX=0';Data Source=" & strPath

cnn.Open str_cnn

For j = 1 To ActiveSheet.Range("CW1").End(xlToLeft).Column

If Len(Cells(2, j).Value) <> 0 Then

StrSQL = StrSQL & " AND " & Cells(1, j).Value & " LIKE '" & Cells(2, j).Value & "'"

End If

Next '到这里都是套路，是要改StrSQL 里面的东西就行了

If Len(Cells(4, 7).Value) <> 0 And Len(Cells(5, 7).Value) <> 0 Then StrSQL = StrSQL & " AND [Delivery completion date] between #" & [G4].Text & "# and #" & [G5].Text & "#"

If Len(Cells(4, 7).Value) <> 0 And Len(Cells(5, 7).Value) = 0 Then StrSQL = StrSQL & "AND [Delivery completion date] > #" & [G4].Text & "#"

If Len(Cells(5, 7).Value) <> 0 And Len(Cells(4, 7).Value) = 0 Then StrSQL = StrSQL & "AND [Delivery completion date] < #" & [G5].Text & "#" ‘三个if都是为了去筛选时间信息

If Len(StrSQL) = 0 Then MsgBox "NO Query infro to Search": Exit Sub

StrSQL = "SELECT * FROM [Database$] WHERE" & Mid(StrSQL, 5)

Set rst = cnn.Execute(StrSQL)

Worksheets("Multi-Query").Range("11:" & Rows.Count).Delete

For i = 0 To rst.Fields.Count - 1

Cells(11, i + 1) = rst.Fields(i).Name

Range("a12").CopyFromRecordset rst

ActiveSheet.UsedRange.Cells(4, 2) = rst.RecordCount

col = ActiveSheet.Range("A11").End(xlToRight).Column

Row = ActiveSheet.Range("A11").End(xlDown).Row

ActiveSheet.ListObjects.Add xlSrcRange, ActiveSheet.Range(Cells(11, 1), Cells(Row, col)), , xlYes

ActiveSheet.Range(Cells(11, 1), Cells(Row, col)).HorizontalAlignment = xlCenter

cnn.Close

Set cnn = Nothing

ActiveSheet.UsedRange.Cells(4, 2) = ActiveSheet.Range("A11").End(xlDown).Row - 11

date1 = dic_value("Delivery completion date", Row, True)

ActiveSheet.UsedRange.Cells(5, 2) = date1

Material = dic_value("Material", Row)

ActiveSheet.UsedRange.Cells(6, 2) = Mid(Material, 2)

Payment = dic_value("Payment", Row)

ActiveSheet.UsedRange.Cells(7, 2) = Mid(Payment, 2)

Contract = dic_value("Contract", Row)

ActiveSheet.UsedRange.Cells(8, 2) = Mid(Contract, 2)

Settle = dic_value("Settle Period", Row)

ActiveSheet.UsedRange.Cells(9, 2) = Mid(Settle, 2)

End Sub

’下面的自定义是为了统计我要的信息，因为我的原表的格式比较特殊所以就写的稍复杂了点，其实还可以优化的更简单，但是懒得弄了凑合用就行了哈

Function dic_value(what As String, Lrow, Optional shijian As Boolean)

Dim r As Object, arr, s, Str

Dim i

Dim Name1 As Date, Name2 As Date, Name3

On Error GoTo earlyexit:

If shijian = True Then

Set dic = CreateObject("Scripting.Dictionary")

Set r = Range(Cells(11, 1), Cells(11, 50)).Find(what)

arr = Worksheets("Multi-Query").Range(Cells(12, r.Column), Cells(Lrow, r.Column))

For i = 1 To UBound(arr)

s = DateValue(arr(i, 1))

If Not dic.exists(s) Then

dic(s) = ""

End If

Next i

Arr1 = dic.Keys

Set dic = Nothing

For i = 0 To UBound(Arr1)

If a = 0 Then a = Arr1(0)

If a > CDate(Arr1(i)) Then a = CDate(Arr1(i))

If b < CDate(Arr1(i)) Then b = CDate(Arr1(i))

Next i

Name1 = a

Name2 = b

Name = Name1 & " - " & Name2

Else

Set dic = CreateObject("Scripting.Dictionary")

Set r = Range(Cells(11, 1), Cells(11, 50)).Find(what)

arr = Worksheets("Multi-Query").Range(Cells(12, r.Column), Cells(Lrow, r.Column))

For i = 1 To UBound(arr)

s = Trim(arr(i, 1))

If Not dic.exists(s) Then

dic(s) = ""

End If

Next i

Arr1 = dic.Keys

Set dic = Nothing

For i = 0 To UBound(Arr1)

Name3 = Arr1(i)

Name = Name & "\ " & Name3

Next i

End If

dic_value = Name

earlyexit:

On Error GoTo 0

End Function

‘结束，其实很简单，有VBA基础的看基本毫无压力的对吧，本想用调用API，但是写的比较匆忙，总之能实现需求的就是好代码，对吧。由于数据涉及到公司敏感信息，凑合看哈。下次更新对后续的数据进行自动透视表分析，拜拜~~~