需求：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
Next
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，但是写的比较匆忙，总之能实现需求的就是好代码，对吧。由于数据涉及到公司敏感信息，凑合看哈。下次更新 对后续的数据进行自动透视表分析，拜拜~~~