Excel VBAADOSQL实例集锦.docx

Excel VBAADOSQL实例集锦.docx

《Excel VBAADOSQL实例集锦.docx》由会员分享，可在线阅读，更多相关《Excel VBAADOSQL实例集锦.docx（93页珍藏版）》请在冰豆网上搜索。

ExcelVBAADOSQL实例集锦

1,包含空值的记录f13isnull

‘

‘订单生成系统.xls

‘f6-第6列，f2-第2列

PrivateSubWorksheet_Activate（）

OnErrorResumeNext

DimxAsObject,yyAsObject,sqlAsString

Setx=CreateObject（"ADODB.Connection"）

x.Open"Provider=Microsoft.Jet.OLEDB.4.0;ExtendedProperties='Excel8.0;hdr=no;';DataSource="&ActiveWorkbook.FullName

sql="selectf6,f2,f3,f4,f5,f7,f13,f24-f25from[sheet1$]wheref24-f25'C3'orf13isnull）"‘不等于字符串用‘C3’包含空值用isnull

Setyy=x.Execute（sql）

Range（"a:

h"）.ClearContents

Range（"a1:

h1"）=Array（"编号","品名","规格","产地","单位","件装","属性","计划"）‘表头另外赋值

[a2].CopyFromRecordsetyy

Setyy=Nothing

Setx=Nothing

EndSub

2，用ADOConnection对象查询

OptionExplicit

PublicconnAsADODB.Connection

SubMyquery（）

DimsConnect$,sql1$

Setconn=CreateObject（"adodb.connection"）

Sheets（"sheet1"）.Cells.ClearContents

sConnect="provider=microsoft.jet.oledb.4.0;extendedproperties=excel8.0;"&_

"DataSource="&ThisWorkbook.Path&"\"&ThisWorkbook.Name

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

ThisWorkbook.Sheets（"sheet1"）.Cells（2,1）.CopyFromRecordsetconn.Execute（sql1）'copy后面紧接SQL查询执行语句

WithSheets（"sheet1"）

.Range（"A1"）="物料代码"'建立表头

.Range（"B1"）="物料描述"

.Range（"C1"）="属性"

.Range（"D1"）="单位"

EndWith

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

EndSub

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

OptionExplicit

SubMyquery（）

DimrdAsADODB.Recordset

Dimi%,j%,k%,sConnect$,sql1$,str$

Setrd=NewADODB.Recordset

str="外协"

Sheets（"sheet1"）.Cells.ClearContents

sConnect="provider=microsoft.jet.oledb.4.0;extendedproperties=excel8.0;"&_

"DataSource="&ThisWorkbook.Path&"\"&ThisWorkbook.Name

'conn.OpensConnect'打开数据源

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

rd.Opensql1,sConnect,adOpenForwardOnly,adLockReadOnly

ThisWorkbook.Sheets（"sheet1"）.Cells（2,1）.CopyFromRecordsetrd

WithSheets（"sheet1"）

.Range（"A1"）="物料代码"'建立表头

.Range（"B1"）="物料描述"

.Range（"C1"）="属性"

.Range（"D1"）="单位"

EndWith

rd.Close'关闭记录集

Setrd=Nothing'关闭

EndSub

4，引用一列，如A列

‘引用单列、单行、单个单元格.xls

'引用一列，如A列

Subonecolumn（）

DimSql$

SetConn=CreateObject（"Adodb.Connection"）

Conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties='excel8.0;hdr=no';datasource="&ThisWorkbook.Path&"\1.xls"

Sql="selectf1from[sheet1$]"

Cells.Clear

[a1].CopyFromRecordsetConn.Execute（Sql）

Conn.Close

SetConn=Nothing

EndSub

Subdgzbhz（）

'2008/12/2

‘

‘Book12021.xls

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

DimSql$

SetConn=CreateObject（"Adodb.Connection"）

[b2:

d4]=""

arr=Array（"一中","二中","三中"）

Fori=0ToUBound（arr）

Conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties='excel8.0;hdr=no';datasource="&ThisWorkbook.Path&"\"&arr（i）&".xls"

Sql="selectf2from[sheet1$]"

Cells（1,i+2）.CopyFromRecordsetConn.Execute（Sql）

Conn.Close

Nexti

SetConn=Nothing

[b1:

d1]=arr

EndSub

‘test1203.xlsEH

‘有标题不用hdr=no，列名用编码文字，可往下连续取数据。

PrivateFunctioncnn（）AsObject

Setcnn=CreateObject（"ADODB.Connection"）

cnn.Open"Provider=Microsoft.Jet.Oledb.4.0;ExtendedProperties='Excel8.0;HDR=no';DataSource="&ThisWorkbook.FullName

EndFunction

Subonecolumn（）

DimSql$,Sht1AsWorksheet,ShtAsWorksheet

Dimn

SetSht1=Sheets（"汇总"）

Sht1.Activate

‘SetConn=CreateObject（"Adodb.Connection"）

‘Conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties='excel8.0';datasource="&ThisWorkbook.FullName

ForEachShtInSheets

IfSht.Name<>"汇总"Then

Sql="select编码from["&Sht.Name&"$]"

n=[b65536].End（xlUp）.Row+1

Sht1.Cells（n,2）.CopyFromRecordsetCnn.Execute（Sql）

EndIf

NextSht

Cnn.Close

SetCnn=Nothing

EndSub

5，引用一行,如第1行

'引用一

Subonerow（）

DimSql$

SetConn=CreateObject（"Adodb.Connection"）

Conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties='excel8.0;hdr=no';datasource="&ThisWorkbook.Path&"\1.xls"

Sql="select*from[sheet1$a1:

iv1]"

Cells.Clear

[a1].CopyFromRecordsetConn.Execute（Sql）

Conn.Close

SetConn=Nothing

EndSub

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

‘2013-3-14

‘2260-1-1.html

DimSql$,Conn

Subtestit（）

DimmyPath$,mvvar,i&,myName$,Myr&

Sheet1.Activate

[a4:

h500].ClearContents

SetConn=CreateObject（"Adodb.Connection"）

myPath=ThisWorkbook.Path&"\"

myName=ThisWorkbook.Name

mvvar=（myPath）

IfTypeName（mvvar）<>"Boolean"Then

Fori=LBound（mvvar）ToUBound（mvvar）

Ifmvvar（i）<>myNameThen

Conn.Open"provider=Microsoft.ACE.OLEDB.12.0;ExtendedProperties='Excel12.0;hdr=no';datasource="&ThisWorkbook.Path&"\"&mvvar（i）

Sql="select*from[sheet1$h6:

h6]"

Myr=[a65536].End（xlUp）.Row+1

IfMyr<4ThenMyr=4

Cells（Myr,3）.CopyFromRecordsetConn.Execute（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）.CopyFromRecordsetConn.Execute（Sql）

Sql="select*from[sheet1$c15:

c15]"

Cells（Myr,5）.CopyFromRecordsetConn.Execute（Sql）

Sql="select*from[sheet1$c16:

c16]"

Cells（Myr,6）.CopyFromRecordsetConn.Execute（Sql）

Conn.Close

EndIf

Next

Else

MsgBox"没有找到文件。

"

EndIf

Myr=Myr+1

Cells（Myr,2）="合计"

Cells（Myr,3）.Formula="=sum（r4c:

r[-1]c）"

Cells（Myr,3）.AutoFillCells（Myr,3）.Resize（1,5）

EndSub

Function（fldr,OptionalfltrAsString="*.xls"）AsVariant

DimsTempAsString,sHldrAsString

IfRight$（fldr,1）<>"\"Thenfldr=fldr&"\"

sTemp=Dir（fldr&fltr）

IfsTemp=""Then

=False

ExitFunction

EndIf

Do

sHldr=Dir

IfsHldr=""ThenExitDo

sTemp=sTemp&"|"&sHldr

Loop

=Split（sTemp,"|"）

EndFunction

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

Subonecell（）

DimSql$

SetConn=CreateObject（"Adodb.Connection"）

Conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties='excel8.0;hdr=no';datasource="&ThisWorkbook.Path&"\1.xls"

Sql="select*from[sheet1$k1:

k1]"

Cells.Clear

[a1].CopyFromRecordsetConn.Execute（Sql）

Conn.Close

SetConn=Nothing

EndSub

PrivateSubCommandButton1_Click（）

'要求从“数据.xlt”中获取Sheet1.range（"C6"）中的数据，并赋给一变量

DimSql$,Conn,rs,str1

SetConn=CreateObject（"Adodb.Connection"）

Setrs=CreateObject（"adodb.recordset"）

Conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties='excel8.0;hdr=no';datasource="&ThisWorkbook.Path&"\数据.xlt"

Sql="select*from[sheet1$c6:

c6]"

rs.Open（Sql）,Conn,1,1

aa=rs.getrows

str1=aa（0,0）

MsgBoxstr1

Conn.Close

SetConn=Nothing

EndSub

7，计算A1+B1

'计算A1+B1

SubA1_Plus_b1（）

DimSql$

SetConn=CreateObject（"Adodb.Connection"）

Conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties='excel8.0;hdr=no';datasource="&ThisWorkbook.Path&"\1.xls"

Sql="selectf1+f2from[sheet1$a1:

b1]"

Cells.Clear

[a1].CopyFromRecordsetConn.Execute（Sql）

Conn.Close

SetConn=Nothing

EndSub

8，计算A1+A2

'计算A1+A2

Subsumcolumn（）

DimSql$

SetConn=CreateObject（"Adodb.Connection"）

Conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties='excel8.0;hdr=no';datasource="&ThisWorkbook.Path&"\1.xls"

Sql="selectsum（f1）from[sheet1$a1:

a2]"

Cells.Clear

[a1].CopyFromRecordsetConn.Execute（Sql）

Conn.Close

SetConn=Nothing

EndSub

进销存汇总0407.xls

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

Sql="select产品代码,sum（进货数量）,sum（进货金额）from[进货$]groupby产品代码"

如果没有groupby，就出错，显示“产品代码”不能汇总。

Sql="select产品代码,'',sum（进货数量）,进货单价,sum（进货金额）from[进货$]groupby产品代码,进货单价"'第2列为空，单价也成组

两表查询

Sql="selectB.产品代码,'',sum（B.进货数量）,B.进货单价,sum（B.进货金额）,sum（C.销售数量）,C.销售单价,sum（C.销售金额）from[进货$]asB,[销售$]asCwhereB.产品代码=C.产品代码groupbyB.产品代码,B.进货单价,C.销售单价"

三表查询

Sql="selectA.产品代码,A.名称,sum（B.进货数量）,B.进货单价,sum（B.进货金额）,sum（C.销售数量）,C.销售单价,sum（C.销售金额）from[产品资料$]asA,[进货$]asB,[销售$]asCwhereA.产品代码=B.产品代码andB.产品代码=C.产品代码groupbyA.产品代码,A.名称,B.进货单价,C.销售单价"

Sql="selectA.产品代码,A.名称,sum（B.进货数量）,B.进货单价,sum（B.进货金额）,sum（C.销售数量）,C.销售单价,sum（C.销售金额）,sum（C.销售数量）*（C.销售单价-B.进货单价）,sum（B.进货数量）-sum（C.销售数量）from[产品资料$]asA,[进货$]asB,[销售$]asCwhereA.产品代码=B.产品代码andB.产品代码=C.产品代码groupbyA.产品代码,A.名称,B.进货单价,C.销售单价"

9，导出工具by:

sgrshh29

‘ado导出工具.xls

‘

PublicSubOutputTxt（strPathAsString,strRangeAsString,LRowAsLong）

OnErrorResumeNext

DimstrSheetNameAsString

DimstrsqlAsString

DimstrTxtnameAsString

DimstrFolderAsString

DimcnnAsObject

DimrsAsObject

strTxtname=Left（strPath,InStr（strPath,"."）-1）&".txt"

strFolder=sNPath&LRow-4

IfDir（strFolder&"\"&strTxtname）<>""ThenKillstrFolder&"\"&strTxtname

Setcnn=CreateObject（"adodb.connection"）

Withcnn

.Provider="Microsoft.Jet.OLEDB.4.0"

.ConnectionString="DataSource="&sPath&"\"&strPath&";ExtendedProperties=Excel8.0;"

.CursorLocation=adUseClient

.Open

EndWith

Setrs=cnn.OpenSchema（adSchemaTables）

DoUntilrs.EOF

IfRight（rs.Fields（"TABLE_NAME"）.Value,1）="$"Then

strSheetName=Mid（rs.Fields（"TABLE_NAME"）.Value,1,Len（rs.Fields（"TABLE_NAME"）.Value）-1）

ExitDo

EndIf

rs.MoveNext

Loop

rs.Close

Setrs=Nothing

strsql="SELECT*INTO["&strTxtname&"]IN'"&strFolder&"''Text;'FROM"_

&"["&strSheetName&"$"&strRange&"]"

cnn.Execute（strsql）

cnn.Close

Setcnn=Nothing

EndSub

10，多表汇总

‘08发票.xls

Sub分类汇总（）

Range（"A1:

N5000"）.ClearContents

Setconn=CreateObject（"adodb.connection"）

conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties=excel8.0;datasource="&ThisWorkbook.FullName

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

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

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

sq4=sq1&"UNIONALL"&sq2&"UNIONALL"&sq3

sq5="select编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,SU