Excel VBA_ADO+SQL实例集锦

1, 包含空值的记录 f13 is null

‘http://www.excelpx.com/dispbbs.asp?boardID=5&ID=46032&page=1 ‘订单生成系统.xls ‘f6-第6列，f2-第2列

Private Sub Worksheet_Activate() On Error Resume Next

Dim x As Object, yy As Object, sql As String Set x = CreateObject(\

x.Open \Properties='Excel 8.0;hdr=no;';Data Source=\

sql = \f13 is null)\ ‘不等于字符串用 ‘C3’ 包含空值用 is null Set yy = x.Execute(sql) Range(\

Range(\编号\品名\规格\产地\单位\件装\属性\计划\ ‘表头 另外赋值

[a2].CopyFromRecordset yy Set yy = Nothing Set x = Nothing End Sub

2，用ADO Connection对象查询

Option Explicit

Public conn As ADODB.Connection Sub Myquery()

Dim sConnect$, sql1$

Set conn = CreateObject(\Sheets(\

sConnect = \ \

sql1 = \物料代码,物料描述,属性,单位 from [物料代码表$] where 属性= '采购' \ '表格名要用[$],条件部分用单引号''

ThisWorkbook.Sheets(\1).CopyFromRecordset conn.Execute(sql1) 'copy后面紧接SQL查询执行语句

With Sheets(\

.Range(\物料代码\ '建立表头 .Range(\物料描述\ .Range(\属性\ .Range(\单位\ End With

'conn.Close '可不用每次关闭数据源的连接 End Sub

3，用记录集执行单个查询

Option Explicit Sub Myquery()

Dim rd As ADODB.Recordset

Dim i%, j%, k%, sConnect$, sql1$, str$ Set rd = New ADODB.Recordset str = \外协\

Sheets(\

sConnect = \ \ 'conn.Open sConnect '打开数据源

sql1 = \物料代码,物料描述,属性,单位 from [物料代码表$] where 属性= '采购' \ '表格名要用[$],条件部分用单引号''

rd.Open sql1, sConnect, adOpenForwardOnly, adLockReadOnly ThisWorkbook.Sheets(\ With Sheets(\

.Range(\物料代码\ '建立表头 .Range(\物料描述\ .Range(\属性\ .Range(\单位\ End With

rd.Close '关闭记录集 Set rd=Nothing '关闭 End Sub

4，引用一列，如A列

‘引用单列、单行、单个单元格.xls '引用一列，如A列 Sub onecolumn() Dim Sql$

Set Conn = CreateObject(\

Conn.Open \properties='excel 8.0;hdr=no';data source=\

Sql = \ Cells.Clear

[a1].CopyFromRecordset Conn.Execute(Sql) Conn.Close

Set Conn = Nothing

End Sub

Sub dgzbhz() '2008/12/2

‘http://www.exceljy.com/viewthread.php?tid=4912&pid=82252&page=1&extra=page=1#pid82252

‘Book12021.xls

‘由于分表的第2列表头是“金额”，不用它，改为“一中”，所以要用hdr=no无标题，拷贝时把第一行表头归零，所以最后要加表头。

Dim Sql$

Set Conn = CreateObject(\ [b2:d4] = \

arr = Array(\一中\二中\三中\ For i = 0 To UBound(arr) Conn.Open \properties='excel 8.0;hdr=no';data source=\

Sql = \

Cells(1, i + 2).CopyFromRecordset Conn.Execute(Sql) Conn.Close Next i

Set Conn = Nothing [b1:d1] = arr End Sub

‘test1203.xls EH

‘有标题不用hdr=no，列名用编码文字，可往下连续取数据。 Private Function cnn() As Object

Set cnn = CreateObject(\ cnn.Open \Properties ='Excel 8.0;HDR=no';Data Source= \

End Function

Sub onecolumn()

Dim Sql$, Sht1 As Worksheet, Sht As Worksheet Dim n

Set Sht1 = Sheets(\汇总\ Sht1.Activate

‘Set Conn = CreateObject(\

‘Conn.Open \& ThisWorkbook.FullName

For Each Sht In Sheets

If Sht.Name <> \汇总\

Sql = \编码 from [\ n = [b65536].End(xlUp).Row + 1

Sht1.Cells(n, 2).CopyFromRecordset Cnn.Execute(Sql) End If Next Sht Cnn.Close

Set Cnn = Nothing End Sub

5，引用一行,如第1行

'引用一

Sub onerow() Dim Sql$

Set Conn = CreateObject(\

Conn.Open \properties='excel 8.0;hdr=no';data source=\

Sql = \ Cells.Clear

[a1].CopyFromRecordset Conn.Execute(Sql) Conn.Close

Set Conn = Nothing End Sub

6，引用一个单元格，如 k1 单元格

‘2013-3-14

‘http://club.excelhome.net/thread-992260-1-1.html Dim Sql$, Conn

Sub testit()

Dim myPath$, mvvar, i&, myName$, Myr& Sheet1.Activate

[a4:h500].ClearContents

Set Conn = CreateObject(\myPath = ThisWorkbook.Path & \myName = ThisWorkbook.Name mvvar = FileList(myPath)

If TypeName(mvvar) <> \

For i = LBound(mvvar) To UBound(mvvar) If mvvar(i) <> myName Then

Conn.Open \Properties='Excel 12.0;hdr=no';data source=\

Sql = \

Myr = [a65536].End(xlUp).Row + 1 If Myr < 4 Then Myr = 4

Cells(Myr, 3).CopyFromRecordset Conn.Execute(Sql) Cells(Myr, 1) = Myr - 3

Cells(Myr, 2) = Left(mvvar(i), Len(mvvar(i)) - 4) Sql = \

Cells(Myr, 4).CopyFromRecordset Conn.Execute(Sql) Sql = \

Cells(Myr, 5).CopyFromRecordset Conn.Execute(Sql) Sql = \

Cells(Myr, 6).CopyFromRecordset Conn.Execute(Sql) Conn.Close End If Next Else

MsgBox \没有找到文件。\End If

Myr = Myr + 1

Cells(Myr, 2) = \合计\

Cells(Myr, 3).Formula = \

Cells(Myr, 3).AutoFill Cells(Myr, 3).Resize(1, 5) End Sub

Function FileList(fldr, Optional fltr As String = \ Dim sTemp As String, sHldr As String

If Right$(fldr, 1) <> \ sTemp = Dir(fldr & fltr) If sTemp = \ FileList = False Exit Function End If Do

sHldr = Dir

If sHldr = \ sTemp = sTemp & \ Loop

FileList = Split(sTemp, \End Function

'引用一个单元格，如 k1 单元格 Sub onecell() Dim Sql$

Set Conn = CreateObject(\

Conn.Open \properties='excel 8.0;hdr=no';data source=\

Sql = \ Cells.Clear

[a1].CopyFromRecordset Conn.Execute(Sql) Conn.Close

Set Conn = Nothing End Sub

Private Sub CommandButton1_Click()

'要求从“数据.xlt”中获取Sheet1.range(\中的数据，并赋给一变量 Dim Sql$, Conn, rs, str1

Set Conn = CreateObject(\ Set rs = CreateObject(\

Conn.Open \properties='excel 8.0;hdr=no';data source=\数据.xlt\

Sql = \ rs.Open (Sql), Conn, 1, 1 aa = rs.getrows str1 = aa(0, 0) MsgBox str1 Conn.Close

Set Conn = Nothing End Sub

7，计算 A1+B1

'计算 A1+B1 Sub A1_Plus_b1() Dim Sql$

Set Conn = CreateObject(\

Conn.Open \properties='excel 8.0;hdr=no';data source=\

Sql = \ Cells.Clear

[a1].CopyFromRecordset Conn.Execute(Sql) Conn.Close

Set Conn = Nothing End Sub

8，计算 A1+A2

'计算 A1+A2 Sub sumcolumn() Dim Sql$

Set Conn = CreateObject(\

Conn.Open \properties='excel 8.0;hdr=no';data source=\

Sql = \ Cells.Clear

[a1].CopyFromRecordset Conn.Execute(Sql) Conn.Close

Set Conn = Nothing End Sub

进销存汇总0407.xls

根据不重复的“产品代码”，汇总数量和金额

Sql = \产品代码,sum(进货数量),sum(进货金额) from [进货$] group by 产品代码 \如果没有group by ，就出错，显示“产品代码”不能汇总。

Sql = \产品代码,' ',sum(进货数量),进货单价,sum(进货金额) from [进货$] group by 产品代码, 进货单价\ '第2列为空，单价也成组

两表查询

Sql = \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 = \A.产品代码,A.名称,sum(B.进货数量),B.进货单价,sum(B.进货金额),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 = \A.产品代码,A.名称,sum(B.进货数量),B.进货单价,sum(B.进货金额),sum(C.销售数量),C.销售单价,sum(C.销售金额),sum(C.销售数量)*(C.销售单价-B.进货单价),sum(B.进货数量)-sum(C.销售数量) from [产品资料$] as A,[进货$] as B,[销售$] as C where A.产品代码=B.产品代码 and B.产品代码=C.产品代码 group by A.产品代码,A.名称,B.进货单价,C.销售单价\

9，导出工具 by:sgrshh29

‘ado导出工具.xls

‘http://club.excelhome.net/dispbbs.asp?boardid=2&replyid=1298919&id=313282&page=1&skin=0&Star=3

Public Sub OutputTxt(strPath As String, strRange As String, LRow As Long) On Error Resume Next

Dim strSheetName As String Dim strsql As String

Dim strTxtname As String Dim strFolder As String Dim cnn As Object Dim rs As Object

strTxtname = Left(strPath, InStr(strPath, \strFolder = sNPath & LRow - 4

If Dir(strFolder & \Set cnn = CreateObject(\

With cnn

.Provider = \

.ConnectionString = \Source=\& sPath & \& strPath & \Properties=Excel 8.0;\

.CursorLocation = adUseClient .Open End With

Set rs = cnn.OpenSchema(adSchemaTables) Do Until rs.EOF

If Right(rs.Fields(\ strSheetName = Mid(rs.Fields(\alue, 1, Len(rs.Fields(\

Exit Do End If

rs.MoveNext Loop rs.Close

Set rs = Nothing

strsql = \ & \cnn.Execute (strsql) cnn.Close

Set cnn = Nothing End Sub

10，多表汇总

‘08发票.xls Sub 分类汇总()

Range(\

Set conn = CreateObject(\

conn.Open \properties=excel 8.0;data source=\& ThisWorkbook.FullName

sq1 = \编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,金额,收入,应收,备注 from [1月$]\

sq2 = \编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,金额,收入,应收,备注 from [2月$]\

sq3 = \编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,金额,收入,应收,备注 from [3月$]\

sq4 = sq1 & \

sq5 = \编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,SUM(金额),sum(收入),sum(应收),备注 from (\编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,备注 order by 发票号\

[a65536].End(xlUp).Offset(1, 0).CopyFromRecordset conn.Execute(sq5) conn.Close

arr = Array(\编号\日期\发票号\客户\案类\案号\律师\业务量\合作人\项目\金额\收入\应收\备注\

[a1:n1] = arr

Set conn = Nothing Columns(\

Selection.NumberFormatLocal = \ Range(\End Sub

11，两工作表查询（ADODB_SQL、按时间段、按客户名）

‘查询.xls （自编宏之五） ‘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 Worksheet Sub anrqcx0130()

Set Sht1 = Worksheets(\查询表\ Set Sht2 = Worksheets(\明细表\ Sht1.Activate

Range(\ dd = [e6] ee = [f6]

wbName = ThisWorkbook.FullName Set cnn = New ADODB.Connection With cnn

.Provider = \

.ConnectionString = \ & \ .Open End With

Sql = \日期,客户名称,品名及规格,数量,单价,金额,备注 from [明细表$] where (日期 between #\

Set rs = New ADODB.Recordset

rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic Sht1.Cells(12, 3).CopyFromRecordset rs [i9].Formula = \ rs.Close

Set rs = Nothing cnn.Close

Set cnn = Nothing Set ws = Nothing

End Sub

Sub ankhcx0130()

Set Sht1 = Worksheets(\查询表\ Set Sht2 = Worksheets(\明细表\ Sht1.Activate

Range(\ aa = [e8]

wbName = ThisWorkbook.FullName Set cnn = New ADODB.Connection With cnn

.Provider = \

.ConnectionString = \ & \ .Open End With

Sql = \日期,客户名称,品名及规格,数量,单价,金额,备注 from [明细表$] where 客户名称='\

Set rs = New ADODB.Recordset

rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic Sht1.Cells(12, 3).CopyFromRecordset rs [i9].Formula = \

18，纯文本查询（字段名用变量）

‘文本字段在A2单元格，查询文本在B2单元格 Sub 纯文本查询() Dim sh As String

Dim sql$, conn As New ADODB.Connection Dim Zdm$, czz$

Const nm = \出仓总查询\ '查询需操作的文件夹 Application.ScreenUpdating = False Zdm = [a2]: czz = Trim([b2])

Range(\

sh = Dir(ThisWorkbook.Path & \出仓数据库\\*.xls\ '数据库文件夹路径 While Not Len(sh) = 0

aa = Left(sh, Len(sh) - 4)

conn.Open \properties=excel 8.0;data source=\出仓数据库\\\

sql = \ \ [a65536].End(xlUp).Offset(1).CopyFromRecordset conn.Execute(sql) conn.Close sh = Dir() Wend

Application.ScreenUpdating = True End Sub

19，两表查询

‘EP Book0422.xls Sub sxhz0422()

Dim Sht2 As Worksheet, Sht3 As Worksheet Dim conn As ADODB.Connection

Dim Sql As String, sql1$, Myr1&, Myr2& Set Sht2 = Worksheets(\ Set Sht3 = Worksheets(\ Sht2.Activate

Myr1 = [a65536].End(xlUp).Row

Set conn = CreateObject(\

conn.Open \ThisWorkbook.FullName

Sql = \ ‘B记录在左，A记录在右，并列显示

‘Sql = \ ‘A记录在左，B记录在右，并列显示

‘Sql = \ left join [Sheet3$] as B on A.txno=B.txno \ ‘在A记录右边，并列显示B相同txno的记录

Sht2.[a65536].End(xlUp).Offset(1, 0).CopyFromRecordset conn.Execute(Sql) Myr2 = [a65536].End(xlUp).Row

Range(Cells(Myr1 + 1, 5), Cells(Myr2, 8)).ClearContents [a1].Select conn.Close

Set conn = Nothing End Sub

20，工资汇总（表格名变量、查询值变量Like）

‘EH help.xls Sub sxhz0422()

Dim Sht2 As Worksheet, Sht3 As Worksheet Dim conn As ADODB.Connection

Dim Sql As String, sql1$, Myr1&, Myr2& Set Sht2 = Worksheets(\生成月工资\ Sht2.Activate

Range(\ cj = Left([d1], 2) '车间 yf = [b1] '月份

Set Sht3 = Worksheets(cj)

Myr1 = [a65536].End(xlUp).Row

Set conn = CreateObject(\

conn.Open \ThisWorkbook.FullName

Sql = \操作员,sum(本日工资),sum(废品损失),sum(设备工作时间) from [\\日期 like '\操作员 \

Sht2.[a3].CopyFromRecordset conn.Execute(Sql) Myr2 = [a65536].End(xlUp).Row [a1].Select conn.Close

Set conn = Nothing End Sub

21，查询（f6,f7）

‘订单生成系统0427.xls

‘http://www.excelpx.com/dispbbs.asp?boardID=5&ID=50456&page=1 Private Sub Worksheet_Activate() On Error Resume Next

Dim x As Object, yy As Object, sql As String

Set x = CreateObject(\

x.Open \Properties='Excel 8.0;hdr=no;';Data Source=\

sql = \f6,f2,f3,f4,f7,f13,f17/2,f24-f25,(f24-f25)\\(f17/60),f17/60*75-f24,round(((f17-f24)/f7)/5,)*5 from [原始数据$] where (f24-f25)'C3'or f13 is null) order by (f24-f25)/(f17/60)\

Set yy = x.Execute(sql) Range(\

Range(\编号\品名\规格\产地\件装\属性\月销售\库存\\周转\计划\件数\实际\

[a2].CopyFromRecordset yy Set yy = Nothing Set x = Nothing End Sub

注：SQL语句中使用f4,f6的话，前面Properties='Excel 8.0;hdr=no’中要加hdr=no。

22，SQL不包含很多内容问题

‘http://club.excelhome.net/dispbbs.asp?boardID=2&ID=319199&page=1&px=0 1、\

join(application.transpose(worksheets(\

2、select * from [sheet2$] where ff not in(select ff from [sheet1$a1:a10])

23，在记录最后新增一条记录（RST.AddNew）

‘精英在线 2008-12-09

Private Sub CommandButton1_Click() '新增记录

Dim ArrValues(0 To 13) Dim ArrFields

ArrFields = Array(\乡镇名称\行政村名\路线编码\路线名称\起点名称\终点名称\\里程\路面类型\路面宽度\行政等级\技术等级\建设计划\计划年限\建设情况\

Set cnn = CreateObject(\

Set rst = CreateObject(\

Stpath = ThisWorkbook.Path & Application.PathSeparator & \农村公路数据库.mdb\ cnn.Provider = \

cnn.Open \ Strsql = \公路信息 where 路线编码='\rst.Open Strsql, cnn, adopendynamic, adlockoptimistic For x = 0 To 13

ArrValues(x) = Me.Controls(\Next x

rst.addnew ArrFields, ArrValues End Sub

24，不打开的多工作簿汇总（FileSearch）

‘http://club.excelhome.net/viewthread.php?tid=376533&highlight=?à1¤×÷2???×ü

Sub pldrwb1203() '汇总.xls

Dim myFs As FileSearch, Sht1 As Worksheet, Sht As Worksheet Dim myPath As String, Filename$

Dim i As Long, n As Long,aa,nm$,na%

Dim conn As Object, yy As Object, sql As String Set Sht1 = ActiveSheet Sht1.[a2:c1000] = \

Set conn = CreateObject(\ Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem .Filename = \

If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

ReDim myfile(1 To n) As String For i = 1 To n

myfile(i) = .FoundFiles(i) Filename = myfile(i)

aa = InStrRev(Filename, \

nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名 If nm = ThisWorkbook.Name Then GoTo 100

conn.Open \properties='excel 8.0';data source=\

sql = \A.单位名称,B.单位人员数量,C.单位领导数量 from [表一$] as A,[表二$] as B,[表三$] as C\

na = Sht1.[a65536].End(xlUp).Row + 1

Sht1.Cells(na, 1).CopyFromRecordset conn.Execute(sql) conn.Close 100: Next i

Set conn = Nothing

Else

MsgBox \该文件夹里没有任何文件\ End If End With [a1].Select

Set myFs = Nothing End Sub

精英在线

‘http://www.exceljy.com/viewthread.php?tid=5381&page=1#pid91432 Sub pldrwb1213() '汇总表.xls

Dim myFs As FileSearch, Sht1 As Worksheet, Sht As Worksheet Dim myPath As String, Filename$

Dim i As Long, n As Long, aa, nm$, na%

Dim conn As Object, yy As Object, sql As String Set Sht1 = ActiveSheet Sht1.[g7:ac25] = \

Set conn = CreateObject(\ Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem .Filename = \

If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

ReDim myfile(1 To n) As String For i = 1 To n

myfile(i) = .FoundFiles(i) Filename = myfile(i)

aa = InStrRev(Filename, \

nm = Right(Filename, Len(Filename) - aa) '带后缀的Excel文件名 If nm = ThisWorkbook.Name Then GoTo 100

conn.Open \properties='excel 8.0;hdr=no';data source=\

nm = Left(nm, Len(nm) - 4)

sql = \ nm = Left(nm, Len(nm) - 3)

Set r1 = Sht1.Range(\ na = r1.Row

Sht1.Cells(na, 7).CopyFromRecordset conn.Execute(sql) conn.Close

100: Next i

Set conn = Nothing Else

MsgBox \该文件夹里没有任何文件\ End If End With [a1].Select

Set myFs = Nothing End Sub

25，Listview模糊查询（ADO+SQL）

‘http://club.excelhome.net/thread-457530-1-1.html ‘SQL_Sample.xls

‘Books3(Version 1).xls

Private Sub UserForm_Initialize() Dim ltm As ListItem On Error Resume Next With Me.ListView1

.ColumnHeaders.Add , , \终端客户\ .ColumnHeaders.Add , , \ .ColumnHeaders.Add , , \ .View = 3 End With End Sub

Private Sub TextBox1_Change() Dim mSQL$ Dim Conn, RST Dim y, i

On Error Resume Next

If TextBox1.Text <> \终端客户,TYPE,T from E_FH where 终端客户 like '%\ ‘此处用了工作表命名应用的特殊用法

Set RST = CreateObject(\ Set Conn = CreateObject(\

Conn.Open \properties=excel 8.0;data source=\& ThisWorkbook.FullName

RST.Open mSQL, Conn,1,1 ListView1.ListItems.Clear For i = 1 To RST.RecordCount y = y + 1

Me.ListView1.ListItems.Add , , RST(\终端客户\

Me.ListView1.ListItems(y).SubItems(1) = RST(\ Me.ListView1.ListItems(y).SubItems(2) = RST(\

RST.MoveNext Next

RST.Close: Conn.Close

Set RST = Nothing: Set Conn = Nothing End Sub

Private Sub ListView1_Click() On Error Resume Next

TextBox2.Text = ListView1.ListItems(ListView1.SelectedItem.Index) End Sub

Private Sub CommandButton1_Click() Unload Me End Sub

问题在http://club.excelhome.net/thread-269780-1-1.html

‘by:zhaogang1960 2010-3-19

‘http://club.excelhome.net/viewthread.php?tid=549165&page=1#pid3650329 ‘模糊查询_listview.xls

'Microsoft ActiveX Data Objects 2.x Library Dim cnn As ADODB.Connection Dim rs As ADODB.Recordset

Private Sub CommandButton1_Click() cnn.Close

Set rs = Nothing Set cnn = Nothing Unload Me End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader) On Error GoTo myerr

ListView1.SortKey = ColumnHeader.Index - 1 If ListView1.SortOrder = lvwDescending Then ListView1.SortOrder = lvwAscending Else

ListView1.SortOrder = lvwDescending End If

ListView1.Sorted = True myerr:

Exit Sub End Sub

Private Sub TextBox1_Change() Dim SQL$, temp$, i&, j& temp = TextBox1.Text

If temp = \

SQL = \ Else

SQL = \商品代码 like '%\商品名称 like '%\分类 like '%\

End If

Set rs = New ADODB.Recordset

rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic On Error Resume Next With ListView1

.ListItems.Clear

For i = 1 To rs.RecordCount

.ListItems.Add , , rs.Fields(0).Value For j = 1 To rs.Fields.Count - 1

.ListItems(i).SubItems(j) = rs.Fields(j).Value Next j

total = total + rs.Fields(3).Value rs.MoveNext Next i End With rs.MoveFirst

Label2.Caption = \共找到 \条记录\ Label3.Caption = \总计: \ TextBox1.SetFocus End Sub

Private Sub UserForm_Initialize()

Dim mydata$, SQL$, i&, j&, a, total As Double a = Array(8, 1.8, 15, 8)

mydata = ThisWorkbook.Path & \ Set cnn = New ADODB.Connection With cnn

.Provider = \ .Open mydata End With

SQL = \ Set rs = New ADODB.Recordset

rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic On Error Resume Next With ListView1

.ColumnHeaders.Clear .ListItems.Clear

.View = lvwReport ' listivew的显示格式为报表格式 .FullRowSelect = True ' 允许整行选中

.Gridlines = True ' 显示网格线 For i = 0 To rs.Fields.Count - 1

.ColumnHeaders.Add , , rs.Fields(i).Name, Width / a(i) Next i

Label2.Caption = \ Label2.Caption = \

For i = 1 To rs.RecordCount

.ListItems.Add , , rs.Fields(0).Value For j = 1 To rs.Fields.Count - 1

.ListItems(i).SubItems(j) = rs.Fields(j).Value Next j

total = total + rs.Fields(3).Value rs.MoveNext Next i End With rs.MoveFirst

Label2.Caption = \共找到 \条记录\ Label3.Caption = \总计: \ TextBox1.SetFocus End Sub

26，ADO+Do+Dir(by:lenghonhhai版主)

‘http://club.excelhome.net/viewthread.php?tid=500108&pid=3288623&page=1&extra=page=1

Private Sub CommandButton1_Click() Dim cn As Object, s$, s1$, x%

Set cn = CreateObject(\s = Dir(ThisWorkbook.Path & \x = 2

Do While s <> \If s <> \数据.xls\

cn.Open \source=\

s1 = \日期,供货商,批号,出库数量,库存数量,往来单位 from [第1页$b3:h65536]\

Range(\ x = Range(\ cn.Close

End If s = Dir Loop End Sub

27，不打开工作簿多表提取数据（ADODB）

‘程序.xls ‘2009-11-10

‘http://club.excelhome.net/viewthread.php?tid=500442&pid=3291071&page=1&extra=page=1#

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row <> 4 Then Exit Sub Dim cn As Object, sql$, s, rst, clbh$, x If x < 5 Or x > 22 Then Exit Sub x = Target.Column

Application.EnableEvents = False

Set cn = CreateObject(\Set rst = CreateObject(\Range(Cells(5, x), Cells(100, x)) = \s = ThisWorkbook.Path & \目录.xls\cn.Open

\

properties=excel

8.0;data

source=\

sql = \目录$] where 定额编号='\rst.Open sql, cn, adOpenStatic ‘提取一行数据 Cells(5, x).Value = rst(\名称及说明\Cells(6, x).Value = rst(\合价\Cells(7, x).Value = rst(\人工\Cells(8, x).Value = rst(\材料\Cells(9, x).Value = rst(\机械\Cells(10, x).Value = rst(\管理费\Cells(11, x).Value = rst(\单位\rst.Close: cn.Close

s = ThisWorkbook.Path & \材料消耗库.xls\

Cn.Open \Properties=Excel 8.0;Data Source=\

Sqlstr = \编号,经办人,单位,发生日期,sum(内容A),sum(内容B),sum(内容C),sum(内容D) From [总表$a3:i1000] where 经办人='\

Sql = \ 编号=\

Sql1 = \ (发生日期 between #\编号,经办人,单位,发生日期\

If jbr = \经办人不能为空白！\ If bh = \

If ks <> \ Sqlstr = Sqlstr & Sql1 Else

Sqlstr = Sqlstr & \编号,经办人,单位,发生日期\ End If

ElseIf ks <> \ Sqlstr = Sqlstr & Sql & Sql1 Else

Sqlstr = Sqlstr & Sql & \编号,经办人,单位,发生日期\ End If

With Sheet2

.[a6:h5536].Clear

.[a6].CopyFromRecordset Cn.Execute(Sqlstr) Myr = .[a65536].End(3).Row .Cells(Myr + 1, 3) = \合计\

.Cells(Myr + 1, 5).Formula = \

.Cells(Myr + 1, 5).AutoFill .Cells(Myr + 1, 5).Resize(1, 4) With .Range(\ .Font.Name = \微软雅黑\ .Font.Size = 10

.HorizontalAlignment = xlCenter .Borders.LineStyle = 1 End With

With .Range(\

.NumberFormat = \月\日\ End With

Cn.Close: Set Cn = Nothing

End With

Application.ScreenUpdating = True End Sub

33，模糊查询（Like）by:alzeng

‘http://club.excelhome.net/thread-595081-1-1.html

Private Sub CommandButton1_Click() Dim Cn As Object, Sqlstr$

Set Cn = CreateObject(\

Cn.Open \Properties=Excel 8.0;Data Source=\

Sqlstr = \数据源$] Where 客户名称&合同名称 Like '%\ ‘%相当于*[b2]*，注意下划线处的用法

[4:65536].Delete

[A4].CopyFromRecordset Cn.Execute(Sqlstr) Cn.Close: Set Cn = Nothing

[A65536].End(3)(2) = \合计\

[D65536].End(3)(2) = \End Sub

34，2级动态数据有效性（ADO RST+组合框）

http://club.excelhome.net/viewthread.php?tid=630577&pid=4268345&page=1&extra=page=1 Private Sub ComboBox1_Change() '先引用MS ADO 2.7

Dim BtArr() As Byte, zdm$

Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset Dim myPath As String Dim myTable As String Me.ComboBox2.Clear

zdm = Me.ComboBox1.Text

myPath = ThisWorkbook.Path & \

cnn.Open \ If Me.ComboBox1 <> \供应商\ myTable = \内容\ Else

myTable = \供应商\ End If

rst.Open \ ‘字段名、表格名用变量 rst.MoveFirst Do

Me.ComboBox2.AddItem rst(zdm) rst.MoveNext

Loop While Not rst.EOF

Me.ComboBox2.SetFocus

End Sub

Private Sub UserForm_Initialize() Dim i As Byte For i = 1 To 5

Me.ComboBox1.AddItem Array(\供应商\单号\描述\单位\货币\Next End Sub

35，TRANSFORM 和 PIVOT by:extyg

‘http://club.excelhome.net/viewthread.php?tid=632810&pid=4286508&page=1&extra=page=1

‘技巧222 有用的交叉查询.xls Sub ADOTransForm1() Dim i As Integer

Dim strSQL As String

Dim cnn As New ADODB.Connection cnn.Open \Properties='Excel 8.0;HDR=no;';Data Source=\

strSQL = \数据表$A3:c] GROUP BY f1 PIVOT f2 in (园地,木薯,其它旱地)\

With Sheet3

.Range(\

.Range(\ .UsedRange = .UsedRange.Value End With cnn.Close

Set cnn = Nothing End Sub

‘dlz.xls Sub aa()

Dim str As String

str = Sheet3.Range(\

Set x = CreateObject(\

x.Open \

SQL = \sum(贷方发生额) SELECT [年度],[月份],[凭证号码],[摘要],[借方发生额],[贷方发生额] FROM [记录] WHERE [一级科目] like'\年度],[月份],[凭证号码],[摘要],[借方发生额],[贷方发生额] pivot 二级科目\

Set y = x.Execute(SQL) For Each zz In y.Fields i = i + 1

Sheet3.Cells(2, i) = zz.Name Next

Sheet3.[a3].CopyFromRecordset y End Sub

‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=147948&star=2#2078289 ‘销售日报表1109.xls Sub xs()

Dim Sql As String, x, y, zz, i, Myr&

Set x = CreateObject(\

x.Open \Properties=Excel 8.0;Data Source=\& ThisWorkbook.FullName

Sql = \销售金额) SELECT 客户 FROM [销售$] group by 客户 pivot 日期\Set y = x.Execute(Sql) i = 6

Sheet1.Activate

Cells(4, 7).Resize(1000, 100).ClearContents For Each zz In y.Fields i = i + 1

Sheet1.Cells(4, i) = zz.Name Next

[g5].CopyFromRecordset y

Myr = [g65536].End(xlUp).Row Range(\Range(\[g3] = \本期销售明细\End Sub

Sub TranPivot() 'by:mineshine

'http://club.excelhome.net/thread-774876-1-1.html

Dim i As Integer, conn As Object, rs As Object, Field As Object Sheet1.Range(\ '清除 Set conn = CreateObject(\ Set rs = CreateObject(\

conn.Open \Properties=Excel 8.0;Data Source=\

Sql = \填数) select 依据 from [Sheet1$a1:c13] group by 依据 pivot 条件 in(0,1,2,3,4,5)\

rs.Open (Sql), conn, 1, 1 For Each Field In rs.fields

If i > 0 Then [O2].Offset(0, i) = Field.Name '条件 i = i + 1 Next

Sheet1.Range(\ '行列转置结果 conn.Close

Set rs = Nothing Set conn = Nothing End Sub

36，多条件多表模糊查询（Like）by:zhaogang1960

‘http://club.excelhome.net/viewthread.php?tid=642360&pid=4363053&page=2&extra= ‘需要先引用Microsoft ActiveX Data Objects 2.x Library Private Sub CommandButton1_Click() Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset Dim strSql$, a, arr, s$, i&

Application.ScreenUpdating = False

[A6].CurrentRegion.Offset(1).ClearContents ‘A6为首的当前区域的下面一行以下的区域清空

If [O4] = \

strSql = \ arr = [A2:M2] For i = 1 To 13

If arr(1, i) <> \ Next

If s = \

strSql = strSql & \

cnn.Open \properties='excel 8.0;hdr=no';data source=\

rst.Open strSql, cnn, adOpenStatic [A7].CopyFromRecordset rst cnn.Close

Set rst = Nothing Set cnn = Nothing 100

Application.ScreenUpdating = True End Sub

37，ADO记录存入数组

‘http://club.excelhome.net/viewthread.php?tid=645766&pid=4383209&page=1&extra=page=

1

Private Sub CommandButton1_Click()

Dim mydata As String, mytable As String, SQL As String Dim x As Long, Fdsarr, Arr

Dim cnn As ADODB.Connection Dim rs As ADODB.Recordset

mydata = ThisWorkbook.Path & \ mytable = \数据表\

Set cnn = New ADODB.Connection With cnn

.Provider = \ .Open mydata End With

SQL = \ Set rs = New ADODB.Recordset

rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic

Fdsarr = Array(\日期\姓名\时间\产品\数量\ ‘字段名 rs.Filter = \姓名='张三'\ ‘过滤条件

Arr = Application.Transpose(rs.GetRows(, 1, Fdsarr)) ‘记录存入数组 For x = 1 To UBound(Arr)

Cells(Arr(x, 1) + 1, 1).Resize(1, 5) = Application.Index(Arr, x, 0) Next rs.Close cnn.Close

Set rs = Nothing Set cnn = Nothing

MsgBox \数据更新完成\End Sub

38，按部门分类 先赋给数组 （GetRows）by:alzeng

‘http://club.excelhome.net/thread-643768-1-1.html ‘ADO_Getrow1106.xls Sub NewSht()

Dim Cn As Object, strSql$ Dim Arr, k%

Set Cn = CreateObject(\

Cn.Open \

Properties=Excel

8.0;Data

Source=\

Arr = Cn.Execute(\部门 From [总表$]\ For k = 0 To UBound(Arr, 2)

strSql = \总表$] Where 部门='\ With Sheets(Arr(0, k)) [A1:C1].Copy .[A1]

.[A2].CopyFromRecordset Cn.Execute(strSql) End With Next

Cn.Close: Set Cn = Nothing End Sub

39，行列转换TRANSFORM 和 PIVOT by:wsri

Sub 行列转制1()

Set rngt = Sheets(\新表\Add = rngt.Address(0, 0)

Dim cnn As New ADODB.Connection Dim rs As New ADODB.Recordset

cnn.Open \ThisWorkbook.FullName

strSQL = \别名 SELECT 规格 FROM [新表$\别名 PIVOT 规格 \

rs.Open (strSQL), cnn, adOpenKeyset, adLockReadOnly For Each Field In rs.Fields ‘aa = Field.Name

[E2].Offset(0, i) = Field.Name i = i + 1 Next

Sheets(\新表\Set rs = Nothing Set cnn = Nothing End Sub

Sub 行列转制2()

Set rngt = Sheets(\出货统计\sAddress = rngt.Address(0, 0)

Dim cnn As New ADODB.Connection Dim rs As New ADODB.Recordset

cnn.Open \ThisWorkbook.FullName

strSQL = \数量) SELECT 材料编号 FROM [出货统计$\

\材料编号 PIVOT DatePart(\日期) & '月'\

rs.Open (strSQL), cnn, adOpenKeyset, adLockReadOnly For Each Field In rs.Fields aa = Field.Name

[E1].Offset(0, i) = Field.Name i = i + 1 Next

Sheet1.Range(\Set rs = Nothing Set cnn = Nothing End Sub

Sub 行列转制3()

Set rngt = Sheets(\新表\sAddress = rngt.Address(0, 0)

Dim cnn As New ADODB.Connection Dim rs As New ADODB.Recordset

cnn.Open \ThisWorkbook.FullName

strSQL = \count(学历) SELECT 部门 FROM [新表$\& sAddress & \GROUP BY 部门 PIVOT 学历 in(大学,大专,中专)\

rs.Open (strSQL), cnn, adOpenKeyset, adLockReadOnly For Each Field In rs.Fields aa = Field.Name

[E1].Offset(0, i) = Field.Name i = i + 1 Next

Sheets(\新表\Set rs = Nothing Set cnn = Nothing End Sub

Sub 行列转制4() Sheets(\总表\

maxrow = Sheets(\总表\Set rngt = Sheets(\总表\sAddress = rngt.Address(0, 0)

Dim cnn As New ADODB.Connection Dim rs As New ADODB.Recordset

cnn.Open \ThisWorkbook.FullName

strSQL = \First(颜色) SELECT 款号,面料开发厂,编号,物料名称,使用部位说明 FROM [总表$\

\BY 款号,面料开发厂,编号,物料名称,使用部位说明 PIVOT 配色

in(-1,-2,-3) \

rs.Open (strSQL), cnn, adOpenKeyset, adLockReadOnly Sheets(\想要的结果\[a2:g1000] = \

For Each Field In rs.Fields aa = Field.Name

Sheets(\想要的结果\ i = i + 1 Next

Sheets(\想要的结果\Set rs = Nothing Set cnn = Nothing End Sub

40，多表查询

‘http://club.excelhome.net/thread-650493-1-1.html ‘面试1118.xls Sub cax()

Dim sht As Worksheet, nm$, m%, Myr& Dim sql$, conn As ADODB.Connection Application.ScreenUpdating = False

nm = \常用联系, 设置, 面试计划汇总表\Range(\Set conn = New ADODB.Connection With conn

.Provider = \

.ConnectionString = \Properties='Excel 8.0;hdr=no;';data source=\& ThisWorkbook.FullName ‘有hdr=no时要加’

.Open End With m = 4

For Each sht In Sheets

If InStr(nm, sht.Name) = 0 Then

sql = \f11>=#\

Cells(m, 1).CopyFromRecordset conn.Execute(sql) Myr = [a65536].End(xlUp).Row m = Myr + 1 End If Next

conn.Close

Set conn = Nothing

Application.ScreenUpdating = True End Sub

40_1，imex用法

Set Cn = CreateObject(\

Cn.Open \Source=\

Arr = Cn.Execute(\总表$] Where f2='\

IMEX ( IMport EXport mode )设置

IMEX 有三种模式，各自引起的读写行为也不同： 0 is Export mode 1 is Import mode

2 is Linked mode (full update capabilities)

我这里特别要说明的就是 IMEX 参数了，因为不同的模式代表著不同的读写行为： 当 IMEX=0 时为“输出模式”，这个模式开启的 Excel 档案只能用来做“写入”用途。 当 IMEX=1 时为“输入模式”，这个模式开启的 Excel 档案只能用来做“读取”用途。 当 IMEX=2 时为“链接模式(完全更新能力”，这个模式开启的 Excel 档案可同时支援“读取”与“写入”用途。

41，对Access多字段汇总

‘http://club.excelhome.net/viewthread.php?tid=650598&pid=4415665&page=1&extra=page=1

Sub yy()

Dim mydata$, mytable$, SQL$ Dim x&, y&, cnn, Arr Dim d, k, t

Set d = CreateObject(\ mydata = ThisWorkbook.Path & \数据库.mdb\ mytable = \数据\

Set cnn = CreateObject(\ With cnn

.Provider = \ .Open mydata End With

SQL = \ Arr = cnn.Execute(SQL).GetRows

本文来源：https://www.bwwdw.com/article/ct86.html