Sub 篩選資料()
Sheets("3-列印").Range("A5:IV65536").ClearContents '清除表格資料
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strDataSrcXlsPath As String
strDataSrcXlsPath = ThisWorkbook.FullName
'ThisWorkbook.FullName = 目前檔案的位置
'I) 以下建立數據庫連接
Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & strDataSrcXlsPath & _
";Extended Properties=Excel 12.0;"
.Open
cn.CursorLocation = adUseClient
End With
'II-1) 準備SQL
Dim strQuery As String
Dim strQueryWorksheet As String
Dim strStartlocation As String
Dim lngRowCounter As Long
strStartlocation = "A4" '起始輸入資料儲存格
strQueryWorksheet = "2-調整" '數據查詢頁面位置
'執行SQL
SQLSERCH = " 負責業務 ='" & Range("A2") & "'"
strQuery = "SELECT * FROM [2-調整$A4:IV5000] where" & SQLSERCH 'from 工作表名稱$儲存格範圍
Set rs = cn.Execute(strQuery)
'III) 把數據抄至所需的位置-取出標題
If rs.Fields.Count > 0 Then
For lngColCounter = 0 To rs.Fields.Count - 1
'輸出標題列
Sheets("3-列印").Range(strStartlocation).Offset(0, lngColCounter) = rs.Fields(lngColCounter).Name
Next lngColCounter
'III-2 把數據庫資料列表拿出
Sheets("3-列印").Range(strStartlocation).Offset(1, 0).CopyFromRecordset rs
Else
MsgBox "篩選結果無資料"
End If
'IV) 關掉/清理連接
cn.Close
'rs.Close
Set cn = Nothing
Set rs = Nothing
End Sub