|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
用ADO+SQL
- Private Sub Worksheet_Change(ByVal Target As Range)
- Dim strDate As String
- If Target.Address(0, 0) = "A1" Then
- strDate = Target.Value
- SelectValByNum strDate
- End If
- End Sub
- Function SelectValByNum(strDate As String)
- Dim strShName As String, shData As Worksheet, shResult As Worksheet, lngRows As Long
- Dim Conn As Object, Rst As Object, strPath As String
- Dim strConn As String, strSQL As String
- Dim rg As Range
-
- strShName = "每日公司汇总"
- Set shData = Sheets(strShName)
- Set shResult = Sheets("个人每日明细")
- lngRows = shData.Range("A" & Rows.Count).End(xlUp).Row
-
- Set Conn = CreateObject("ADODB.Connection")
- Set Rst = CreateObject("ADODB.Recordset")
- strPath = ThisWorkbook.FullName
- Select Case Application.Version * 1
- Case Is <= 11
- strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & strPath
- Case Is >= 12
- strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0;HDR=NO"";"""
- End Select
- Conn.Open strConn
- '''''''''''''''''''''''''''''''''
- strSQL = "SELECT [F2],[F4],[F5],[F6],[F7],[F8],[F9],[F10],[F11],[F12] " & _
- "FROM [" & strShName & "$A4:L" & lngRows & "] " & _
- "WHERE [F1] LIKE '" & strDate & "'"
- Rst.Open strSQL, Conn, 3, 1 '执行查询,并将结果输出到记录集对象
-
- shResult.Range("A3:J" & Rows.Count).Clear
- Set rg = shResult.Range("A3")
-
- rg.CopyFromRecordset Rst
- Set Rst = Nothing
- Set Conn = Nothing
- End Function
复制代码 |
评分
-
1
查看全部评分
-
|