Excel VBA_ADO+SQL实例集锦

1、1, 包含空值的记录 f13 is null /dispbbs.asp?boardID=5&ID=46032&page=1订单生成系统.xlsf6-第6列，f2-第2列Private Sub Worksheet_Activate() On Error Resume Next Dim x As Object, yy As Object, sql As String Set x = CreateObject(ADODB.Connection) x.Open Provider=Microsoft.Jet.OLEDB.4.0;Extended Properti

2、es=Excel 8.0;hdr=no;Data Source= & ActiveWorkbook.FullName sql = select f6,f2,f3,f4,f5,f7,f13,f24 -f25 from sheet1$ where f24 -f25f17 and (f13C3 or f13 is null) 不等于字符串用 C3 包含空值用 is null Set yy = x.Execute(sql) Range(a:h).ClearContents Range(a1:h1) = Array(编号, 品名, 规格, 产地, 单位, 件装, 属性, 计划) 表头 另外赋值 a2.C

3、opyFromRecordset yy Set yy = Nothing Set x = NothingEnd Sub2，用ADO Connection对象查询Option ExplicitPublic conn As ADODB.ConnectionSub Myquery()Dim sConnect$, sql1$Set conn = CreateObject(adodb.connection)Sheets(sheet1).Cells.ClearContentssConnect = provider=microsoft.jet.oledb.4.0;extended properties=ex

4、cel 8.0; & _ Data Source= & ThisWorkbook.Path & & ThisWorkbook.Namesql1 = select 物料代码,物料描述,属性,单位 from 物料代码表$ where 属性= 采购 表格名要用$,条件部分用单引号 ThisWorkbook.Sheets(sheet1).Cells(2, 1).CopyFromRecordset conn.Execute(sql1) copy后面紧接SQL查询执行语句 With Sheets(sheet1) .Range(A1) = 物料代码 建立表头 .Range(B1) = 物料描述 .Range

5、(C1) = 属性 .Range(D1) = 单位 End With conn.Close 可不用每次关闭数据源的连接End Sub3，用记录集执行单个查询Option ExplicitSub Myquery()Dim rd As ADODB.RecordsetDim i%, j%, k%, sConnect$, sql1$, str$Set rd = New ADODB.Recordsetstr = 外协Sheets(sheet1).Cells.ClearContentssConnect = provider=microsoft.jet.oledb.4.0;extended properti

6、es=excel 8.0; & _ Data Source= & ThisWorkbook.Path & & ThisWorkbook.Name conn.Open sConnect 打开数据源 sql1 = select 物料代码,物料描述,属性,单位 from 物料代码表$ where 属性= 采购 表格名要用$,条件部分用单引号 rd.Open sql1, sConnect, adOpenForwardOnly, adLockReadOnly ThisWorkbook.Sheets(sheet1).Cells(2, 1).CopyFromRecordset rd With Sheets(

7、sheet1) .Range(A1) = 物料代码 建立表头 .Range(B1) = 物料描述 .Range(C1) = 属性 .Range(D1) = 单位 End With rd.Close 关闭记录集 Set rd=Nothing 关闭End Sub4，引用一列，如A列引用单列、单行、单个单元格.xls引用一列，如A列Sub onecolumn() Dim Sql$ Set Conn = CreateObject(Adodb.Connection) Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel

8、8.0;hdr=no;data source= & ThisWorkbook.Path & 1.xls Sql = select f1 from sheet1$ Cells.Clear a1.CopyFromRecordset Conn.Execute(Sql) Conn.Close Set Conn = NothingEnd SubSub dgzbhz()2008/12/2/viewthread.php?tid=4912&pid=82252&page=1&extra=page%3D1#pid82252Book12021.xls由于分表的第2列表头是“

9、金额”，不用它，改为“一中”，所以要用hdr=no无标题，拷贝时把第一行表头归零，所以最后要加表头。 Dim Sql$ Set Conn = CreateObject(Adodb.Connection) b2:d4 = arr = Array(一中, 二中, 三中) For i = 0 To UBound(arr) Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;hdr=no;data source= & ThisWorkbook.Path & & arr(i) & .xls Sql = sele

10、ct f2 from sheet1$ Cells(1, i + 2).CopyFromRecordset Conn.Execute(Sql) Conn.Close Next i Set Conn = Nothing b1:d1 = arrEnd Subtest1203.xls EH有标题不用hdr=no，列名用编码文字，可往下连续取数据。Private Function cnn() As Object Set cnn = CreateObject(ADODB.Connection) cnn.Open Provider=Microsoft.Jet.Oledb.4.0;Extended Prope

11、rties =Excel 8.0;HDR=no;Data Source= & ThisWorkbook.FullNameEnd FunctionSub onecolumn() Dim Sql$, Sht1 As Worksheet, Sht As Worksheet Dim n Set Sht1 = Sheets(汇总) Sht1.Activate Set Conn = CreateObject(Adodb.Connection) Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data sour

12、ce= & ThisWorkbook.FullName For Each Sht In Sheets If Sht.Name 汇总 Then Sql = select 编码 from & Sht.Name & $ n = b65536.End(xlUp).Row + 1 Sht1.Cells(n, 2).CopyFromRecordset Cnn.Execute(Sql) End If Next Sht Cnn.Close Set Cnn = NothingEnd Sub5，引用一行,如第1行引用一Sub onerow() Dim Sql$ Set Conn = CreateObject(Ad

13、odb.Connection) Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;hdr=no;data source= & ThisWorkbook.Path & 1.xls Sql = select * from sheet1$a1:iv1 Cells.Clear a1.CopyFromRecordset Conn.Execute(Sql) Conn.Close Set Conn = NothingEnd Sub6，引用一个单元格，如 k1 单元格2013-3-14http:/club.exce

14、/thread-992260-1-1.html Dim Sql$, ConnSub testit()Dim myPath$, mvvar, i&, myName$, Myr&Sheet1.Activatea4:h500.ClearContentsSet Conn = CreateObject(Adodb.Connection)myPath = ThisWorkbook.Path & myName = ThisWorkbook.Namemvvar = FileList(myPath)If TypeName(mvvar) Boolean Then For i = LBound(m

15、vvar) To UBound(mvvar) If mvvar(i) myName Then Conn.Open provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;hdr=no;data source= & ThisWorkbook.Path & & mvvar(i) Sql = select * from sheet1$h6:h6 Myr = a65536.End(xlUp).Row + 1 If Myr 4 Then Myr = 4 Cells(Myr, 3).CopyFromRecordset Conn.Ex

16、ecute(Sql) Cells(Myr, 1) = Myr - 3 Cells(Myr, 2) = Left(mvvar(i), Len(mvvar(i) - 4) Sql = select * from sheet1$c14:c14 Cells(Myr, 4).CopyFromRecordset Conn.Execute(Sql) Sql = select * from sheet1$c15:c15 Cells(Myr, 5).CopyFromRecordset Conn.Execute(Sql) Sql = select * from sheet1$c16:c16 Cells(Myr,

17、6).CopyFromRecordset Conn.Execute(Sql) Conn.Close End If NextElse MsgBox 没有找到文件。End IfMyr = Myr + 1Cells(Myr, 2) = 合计Cells(Myr, 3).Formula = =sum(r4c:r-1c)Cells(Myr, 3).AutoFill Cells(Myr, 3).Resize(1, 5)End SubFunction FileList(fldr, Optional fltr As String = *.xls) As Variant Dim sTemp As String,

18、sHldr As String If Right$(fldr, 1) Then fldr = fldr & sTemp = Dir(fldr & fltr) If sTemp = Then FileList = False Exit Function End If Do sHldr = Dir If sHldr = Then Exit Do sTemp = sTemp & | & sHldr Loop FileList = Split(sTemp, |)End Function引用一个单元格，如 k1 单元格Sub onecell() Dim Sql$ Set Conn = CreateObj

19、ect(Adodb.Connection) Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;hdr=no;data source= & ThisWorkbook.Path & 1.xls Sql = select * from sheet1$k1:k1 Cells.Clear a1.CopyFromRecordset Conn.Execute(Sql) Conn.Close Set Conn = NothingEnd SubPrivate Sub CommandButton1_Click() 要求

20、从“数据.xlt”中获取Sheet1.range(C6)中的数据，并赋给一变量 Dim Sql$, Conn, rs, str1 Set Conn = CreateObject(Adodb.Connection) Set rs = CreateObject(adodb.recordset) Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;hdr=no;data source= & ThisWorkbook.Path & 数据.xlt Sql = select * from sheet1$c6:c6

21、 rs.Open (Sql), Conn, 1, 1 aa = rs.getrows str1 = aa(0, 0) MsgBox str1 Conn.Close Set Conn = NothingEnd Sub7，计算 A1+B1计算 A1+B1Sub A1_Plus_b1() Dim Sql$ Set Conn = CreateObject(Adodb.Connection) Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;hdr=no;data source= & ThisWorkbook

22、.Path & 1.xls Sql = select f1+f2 from sheet1$a1:b1 Cells.Clear a1.CopyFromRecordset Conn.Execute(Sql) Conn.Close Set Conn = NothingEnd Sub8，计算 A1+A2计算 A1+A2Sub sumcolumn() Dim Sql$ Set Conn = CreateObject(Adodb.Connection) Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;hdr=

23、no;data source= & ThisWorkbook.Path & 1.xls Sql = select sum(f1) from sheet1$a1:a2 Cells.Clear a1.CopyFromRecordset Conn.Execute(Sql) Conn.Close Set Conn = NothingEnd Sub进销存汇总0407.xls根据不重复的“产品代码”，汇总数量和金额Sql = select 产品代码,sum(进货数量),sum(进货金额) from 进货$ group by 产品代码 如果没有group by ，就出错，显示“产品代码”不能汇总。Sql =

24、 select 产品代码, ,sum(进货数量),进货单价,sum(进货金额) from 进货$ group by 产品代码, 进货单价 第2列为空，单价也成组两表查询Sql = select B.产品代码, ,sum(B.进货数量),B.进货单价,sum(B.进货金额),sum(C.销售数量),C.销售单价,sum(C.销售金额) from 进货$ as B,销售$ as C where B.产品代码=C.产品代码 group by B.产品代码,B.进货单价,C.销售单价 三表查询Sql = select A.产品代码,A.名称,sum(B.进货数量),B.进货单价,sum(B.进货金额)

25、,sum(C.销售数量),C.销售单价,sum(C.销售金额) from 产品资料$ as A,进货$ as B,销售$ as C where A.产品代码=B.产品代码 and B.产品代码=C.产品代码 group by A.产品代码,A.名称,B.进货单价,C.销售单价Sql = select A.产品代码,A.名称,sum(B.进货数量),B.进货单价,sum(B.进货金额),sum(C.销售数量),C.销售单价,sum(C.销售金额),sum(C.销售数量)*(C.销售单价-B.进货单价),sum(B.进货数量)-sum(C.销售数量) from 产品资料$ as A,进货$ as

26、B,销售$ as C where A.产品代码=B.产品代码 and B.产品代码=C.产品代码 group by A.产品代码,A.名称,B.进货单价,C.销售单价9，导出工具 by:sgrshh29ado导出工具.xls/dispbbs.asp?boardid=2&replyid=1298919&id=313282&page=1&skin=0&Star=3Public Sub OutputTxt(strPath As String, strRange As String, LRow As Long)On Error Resume NextDi

27、m strSheetName As StringDim strsql As StringDim strTxtname As StringDim strFolder As StringDim cnn As ObjectDim rs As ObjectstrTxtname = Left(strPath, InStr(strPath, .) - 1) & .txtstrFolder = sNPath & LRow - 4If Dir(strFolder & & strTxtname) Then Kill strFolder & & strTxtnameSet cnn = CreateObject(a

28、dodb.connection)With cnn .Provider = Microsoft.Jet.OLEDB.4.0 .ConnectionString = Data Source= & sPath & & strPath & ;Extended Properties=Excel 8.0; .CursorLocation = adUseClient .OpenEnd WithSet rs = cnn.OpenSchema(adSchemaTables)Do Until rs.EOF If Right(rs.Fields(TABLE_NAME).Value, 1) = $ Then strS

29、heetName = Mid(rs.Fields(TABLE_NAME).Value, 1, Len(rs.Fields(TABLE_NAME).Value) - 1) Exit Do End If rs.MoveNextLooprs.CloseSet rs = Nothingstrsql = SELECT * INTO & strTxtname & IN & strFolder & Text; FROM _ & & strSheetName & $ & strRange & cnn.Execute (strsql)cnn.CloseSet cnn = NothingEnd Sub10，多表汇

30、总08发票.xlsSub 分类汇总() Range(A1:N5000).ClearContents Set conn = CreateObject(adodb.connection) conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= & ThisWorkbook.FullName sq1 = select 编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,金额,收入,应收,备注 from 1月$ sq2 = select 编号,日期,发票号,客户,案类,案号

31、,律师,业务量,合作人,项目,金额,收入,应收,备注 from 2月$ sq3 = select 编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,金额,收入,应收,备注 from 3月$ sq4 = sq1 & UNION ALL & sq2 & UNION ALL & sq3 sq5 = select 编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,SUM(金额),sum(收入),sum(应收),备注 from ( & sq4 & ) GROUP BY 编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,备注 order by 发票号 a65

32、536.End(xlUp).Offset(1, 0).CopyFromRecordset conn.Execute(sq5) conn.Close arr = Array(编号, 日期, 发票号, 客户, 案类, 案号, 律师, 业务量, 合作人, 项目, 金额, 收入, 应收, 备注) a1:n1 = arr Set conn = Nothing Columns(B:B).Select Selection.NumberFormatLocal = yyyy-mm-dd Range(A2).SelectEnd Sub11，两工作表查询（ADODB_SQL、按时间段、按客户名）查询.xls （自编

33、宏之五）Excel论坛 Dim cnn As ADODB.Connection Dim rs As ADODB.Recordset Dim Sql As String Dim wbName As String, i&, aa$, bb$, cc$, dd$, ee$, Myr%, j% Dim Sht1 As Worksheet, Sht2 As WorksheetSub anrqcx0130() Set Sht1 = Worksheets(查询表) Set Sht2 = Worksheets(明细表) Sht1.Activate Range(c12:i29).ClearContents dd

34、 = e6 ee = f6 wbName = ThisWorkbook.FullName Set cnn = New ADODB.Connection With cnn .Provider = microsoft.jet.oledb.4.0 .ConnectionString = Extended Properties=Excel 8.0; _ & Data Source= & wbName .Open End With Sql = select 日期,客户名称,品名及规格,数量,单价,金额,备注 from 明细表$ where (日期 between # & dd & # and # & e

35、e & # ) Set rs = New ADODB.Recordset rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic Sht1.Cells(12, 3).CopyFromRecordset rs i9.Formula = =sum(h12:h29) rs.Close Set rs = Nothing cnn.Close Set cnn = Nothing Set ws = NothingEnd SubSub ankhcx0130() Set Sht1 = Worksheets(查询表) Set Sht2 = Worksheets(明细表)

36、Sht1.Activate Range(c12:i29).ClearContents aa = e8 wbName = ThisWorkbook.FullName Set cnn = New ADODB.Connection With cnn .Provider = microsoft.jet.oledb.4.0 .ConnectionString = Extended Properties=Excel 8.0; _ & Data Source= & wbName .Open End With Sql = select 日期,客户名称,品名及规格,数量,单价,金额,备注 from 明细表$ w

37、here 客户名称= & aa & Set rs = New ADODB.Recordset rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic Sht1.Cells(12, 3).CopyFromRecordset rs i9.Formula = =sum(h12:h29) rs.Close Set rs = Nothing cnn.Close Set cnn = Nothing Set ws = NothingEnd Sub12，多条件、有区间统计（ADOSql）AAA1.xls （自编宏之四）Sub tj1203()http:/www.exc

38、/dispbbs.asp?boardID=5&ID=32274&page=1 Dim cnn As ADODB.Connection Dim rs As ADODB.Recordset Dim Sql As String Dim wbName As String, i&, aa$, bb$, cc$, dd$, ee$, Myr%, j% Dim ws As Worksheet, Sht1 As Worksheet Set ws = Worksheets(Sheet3) Set Sht1 = Worksheets(Sheet2) Sht1.Activate Myr = a655

39、36.End(xlUp).Row dd = c1 ee = d1 wbName = ThisWorkbook.FullName 建立与当前工作簿的连接 Set cnn = New ADODB.Connection With cnn .Provider = microsoft.jet.oledb.4.0 .ConnectionString = Extended Properties=Excel 8.0; _ & Data Source= & wbName .Open End With For i = 4 To Myr aa = Cells(i, 1) For j = 2 To 22 bb = C

40、ells(3, j) cc = Cells(3, j + 1) If j = 3 Or j = 6 Or j = 8 Or j = 12 Or j = 14 Or j = 16 Or j = 18 Or j = 20 Then GoTo 100 If j = 4 Or j = 9 Or j = 10 Or j = 21 Or j = 22 Then Sql = select sum(价税合计) from 数据$ where 客户名称= & aa & and (开票日期 between # & dd & # and # & ee & #) and (存货编码 = & bb & ) Else Sq

41、l = select sum(价税合计) from 数据$ where 客户名称= & aa & and (开票日期 between # & dd & # and # & ee & #) and (存货编码 between & bb & and & cc & ) End If Set rs = New ADODB.Recordset rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic Sht1.Cells(i, j).CopyFromRecordset rs rs.Close Set rs = Nothing100: Next j Next i c

42、nn.Close Set cnn = Nothing Set ws = NothingEnd Sub13，不打开工作簿汇总（ADODB）/thread-394891-1-1.html汇总.xls （自编宏之四）Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Count 1 Then Exit SubIf Target.Column 1 Then Exit SubIf Target.Offset(0, 1) Then Exit SubCall huiz112

43、2End SubSub huiz1122()Dim f As String, n As Long, Myr%, nmDim conn As ADODB.ConnectionDim Sht As WorksheetApplication.ScreenUpdating = FalseSet Sht = Sheets(Sheet1)Sht.ActivateMyr = a65536.End(xlUp).RowIf Myr 1 Then nm = Cells(Myr, 1) On Error Resume Next f = nm & .xls Set conn = New ADODB.Connectio

44、n conn.Open dsn=excel files;dbq= & ThisWorkbook.Path & & f Cells(Myr, 1).CopyFromRecordset conn.Execute(select * from Sheet1$ where 工号= & nm & ) conn.Close Set conn = NothingElse MsgBox 请输入工号！End IfApplication.ScreenUpdating = TrueEnd Sub14，不打开工作簿多表提取数据（ADODB）By:兰色幻想Sub 合并数据()Dim Y As LongY = a65536

45、.End(xlUp).Row + 1Range(A2:G & Y).ClearContentsSet Conn = CreateObject(adodb.connection) （1）设置对象For X = 1 To 4Conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= & ThisWorkbook.Path & / & X & 月.xlsSql = select * from & X & 月$ & a65536.End(xlUp).Offset(1, 0).CopyFrom

46、Recordset Conn.Execute(Sql)Conn.Close 关闭链接Next XSet Conn = Nothing 释放对象变量End Sub15，筛选工作表By:兰色幻想工作表记录的模糊筛选.xlsSub 筛选以A开头的记录()Range(A2:C100).ClearContentsSet conn = CreateObject(adodb.connection)conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= & ThisWorkbook.FullNa

47、meSq1 = select * from Sheet1$ WHERE 型号 Like A%a65536.End(xlUp).Offset(1, 0).CopyFromRecordset conn.Execute(Sq1)conn.CloseSet conn = NothingEnd SubSub 筛选非A开头的记录()Range(A2:C100).ClearContentsSet conn = CreateObject(adodb.connection)conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8

48、.0;data source= & ThisWorkbook.FullNameSq1 = select * from Sheet1$ WHERE 型号 NOT Like A%a65536.End(xlUp).Offset(1, 0).CopyFromRecordset conn.Execute(Sq1)conn.CloseSet conn = NothingEnd SubSub 筛选以C至G开头的记录()Range(A2:C100).ClearContentsSet conn = CreateObject(adodb.connection)conn.Open provider=microsof

49、t.jet.oledb.4.0;extended properties=excel 8.0;data source= & ThisWorkbook.FullNameSq1 = select * from Sheet1$ WHERE 型号 Like C-G%a65536.End(xlUp).Offset(1, 0).CopyFromRecordset conn.Execute(Sq1)conn.CloseSet conn = NothingEnd SubSub 筛选以A开头字符长度为5的记录()Range(A2:C100).ClearContentsSet conn = CreateObject(adodb.connection)conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= & ThisWorkbook.FullNameSq1 = select * from Sheet1$