excelvbaado+sql实例集锦.docx
《excelvbaado+sql实例集锦.docx》由会员分享，可在线阅读，更多相关《excelvbaado+sql实例集锦.docx（88页珍藏版）》请在冰点文库上搜索。
excelvbaado+sql实例集锦
1,包含空值的记录f13isnull
‘&ID=46032&page=1
‘订单生成系统.xls
‘f6-第6列，f2-第2列
PrivateSubWorksheet_Activate（）
OnErrorResumeNext
DimxAsObject,yyAsObject,sqlAsString
Setx=CreateObject（""）
"Provider=Properties='Excel;hdr=no;';DataSource="&
sql="selectf6,f2,f3,f4,f5,f7,f13,f24-f25from[sheet1$]wheref24-f25'C3'orf13isnull）"‘不等于字符串用‘C3’包含空值用isnull
Setyy=（sql）
Range（"a:
h"）.ClearContents
Range（"a1:
h1"）=Array（"编号","品名","规格","产地","单位","件装","属性","计划"）‘表头另外赋值
[a2].CopyFromRecordsetyy
Setyy=Nothing
Setx=Nothing
EndSub
2，用ADOConnection对象查询
OptionExplicit
PublicconnAs
SubMyquery（）
DimsConnect$,sql1$
Setconn=CreateObject（""）
Sheets（"sheet1"）.
sConnect="provider=properties=excel;"&_
"DataSource="&&"\"&
sql1="select物料代码,物料描述,属性,单位from[物料代码表$]where属性='采购'"'表格名要用[$],条件部分用单引号''
（"sheet1"）.Cells（2,1）.CopyFromRecordset（sql1）'copy后面紧接SQL查询执行语句
WithSheets（"sheet1"）
.Range（"A1"）="物料代码"'建立表头
.Range（"B1"）="物料描述"
.Range（"C1"）="属性"
.Range（"D1"）="单位"
EndWith
''可不用每次关闭数据源的连接
EndSub
3，用记录集执行单个查询
OptionExplicit
SubMyquery（）
DimrdAs
Dimi%,j%,k%,sConnect$,sql1$,str$
Setrd=New
str="外协"
Sheets（"sheet1"）.
sConnect="provider=properties=excel;"&_
"DataSource="&&"\"&
'sConnect'打开数据源
sql1="select物料代码,物料描述,属性,单位from[物料代码表$]where属性='采购'"'表格名要用[$],条件部分用单引号''
sql1,sConnect,adOpenForwardOnly,adLockReadOnly
（"sheet1"）.Cells（2,1）.CopyFromRecordsetrd
WithSheets（"sheet1"）
.Range（"A1"）="物料代码"'建立表头
.Range（"B1"）="物料描述"
.Range（"C1"）="属性"
.Range（"D1"）="单位"
EndWith
'关闭记录集
Setrd=Nothing'关闭
EndSub
4，引用一列，如A列
‘引用单列、单行、单个单元格.xls
'引用一列，如A列
Subonecolumn（）
DimSql$
SetConn=CreateObject（""）
"provider=properties='excel;hdr=no';datasource="&&"\"
Sql="selectf1from[sheet1$]"
[a1].CopyFromRecordset（Sql）
SetConn=Nothing
EndSub
Subdgzbhz（）
'2008/12/2
‘&pid=82252&page=1&extra=page%3D1#pid82252
‘
‘由于分表的第2列表头是“金额”，不用它，改为“一中”，所以要用hdr=no无标题，拷贝时把第一行表头归零，所以最后要加表头。
DimSql$
SetConn=CreateObject（""）
[b2:
d4]=""
arr=Array（"一中","二中","三中"）
Fori=0ToUBound（arr）
"provider=properties='excel;hdr=no';datasource="&&"\"&arr（i）&".xls"
Sql="selectf2from[sheet1$]"
Cells（1,i+2）.CopyFromRecordset（Sql）
Nexti
SetConn=Nothing
[b1:
d1]=arr
EndSub
‘EH
‘有标题不用hdr=no，列名用编码文字，可往下连续取数据。
PrivateFunctioncnn（）AsObject
Setcnn=CreateObject（""）
"Provider=Properties='Excel;HDR=no';DataSource="&
EndFunction
Subonecolumn（）
DimSql$,Sht1AsWorksheet,ShtAsWorksheet
Dimn
SetSht1=Sheets（"汇总"）
‘SetConn=CreateObject（""）
‘"provider=properties='excel';datasource="&
ForEachShtInSheets
If<>"汇总"Then
Sql="select编码from["&&"$]"
n=[b65536].End（xlUp）.Row+1
（n,2）.CopyFromRecordset（Sql）
EndIf
NextSht
SetCnn=Nothing
EndSub
5，引用一行,如第1行
'引用一
Subonerow（）
DimSql$
SetConn=CreateObject（""）
"provider=properties='excel;hdr=no';datasource="&&"\"
Sql="select*from[sheet1$a1:
iv1]"
[a1].CopyFromRecordset（Sql）
SetConn=Nothing
EndSub
6，引用一个单元格，如k1单元格
‘2013-3-14
‘2260-1-1DimSql$,Conn
Subtestit（）
DimmyPath$,mvvar,i&,myName$,Myr&
[a4:
h500].ClearContents
SetConn=CreateObject（""）
myPath=&"\"
myName=
mvvar=FileList（myPath）
IfTypeName（mvvar）<>"Boolean"Then
Fori=LBound（mvvar）ToUBound（mvvar）
Ifmvvar（i）<>myNameThen
"provider=Properties='Excel;hdr=no';datasource="&&"\"&mvvar（i）
Sql="select*from[sheet1$h6:
h6]"
Myr=[a65536].End（xlUp）.Row+1
IfMyr<4ThenMyr=4
Cells（Myr,3）.CopyFromRecordset（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（Sql）
Sql="select*from[sheet1$c15:
c15]"
Cells（Myr,5）.CopyFromRecordset（Sql）
Sql="select*from[sheet1$c16:
c16]"
Cells（Myr,6）.CopyFromRecordset（Sql）
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
FunctionFileList（fldr,OptionalfltrAsString="*.xls"）AsVariant
DimsTempAsString,sHldrAsString
IfRight$（fldr,1）<>"\"Thenfldr=fldr&"\"
sTemp=Dir（fldr&fltr）
IfsTemp=""Then
FileList=False
ExitFunction
EndIf
Do
sHldr=Dir
IfsHldr=""ThenExitDo
sTemp=sTemp&"|"&sHldr
Loop
FileList=Split（sTemp,"|"）
EndFunction
'引用一个单元格，如k1单元格
Subonecell（）
DimSql$
SetConn=CreateObject（""）
"provider=properties='excel;hdr=no';datasource="&&"\"
Sql="select*from[sheet1$k1:
k1]"
[a1].CopyFromRecordset（Sql）
SetConn=Nothing
EndSub
PrivateSubCommandButton1_Click（）
'要求从“数据.xlt”中获取（"C6"）中的数据，并赋给一变量
DimSql$,Conn,rs,str1
SetConn=CreateObject（""）
Setrs=CreateObject（""）
"provider=properties='excel;hdr=no';datasource="&&"\数据.xlt"
Sql="select*from[sheet1$c6:
c6]"
（Sql）,Conn,1,1
aa=
str1=aa（0,0）
MsgBoxstr1
SetConn=Nothing
EndSub
7，计算A1+B1
'计算A1+B1
SubA1_Plus_b1（）
DimSql$
SetConn=CreateObject（""）
"provider=properties='excel;hdr=no';datasource="&&"\"
Sql="selectf1+f2from[sheet1$a1:
b1]"
[a1].CopyFromRecordset（Sql）
SetConn=Nothing
EndSub
8，计算A1+A2
'计算A1+A2
Subsumcolumn（）
DimSql$
SetConn=CreateObject（""）
"provider=properties='excel;hdr=no';datasource="&&"\"
Sql="selectsum（f1）from[sheet1$a1:
a2]"
[a1].CopyFromRecordset（Sql）
SetConn=Nothing
EndSub
进销存汇总
根据不重复的“产品代码”，汇总数量和金额
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
‘&replyid=1298919&id=313282&page=1&skin=0&Star=3
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（""）
Withcnn
.Provider=""
.ConnectionString="DataSource="&sPath&"\"&strPath&";ExtendedProperties=Excel;"
.CursorLocation=adUseClient
.Open
EndWith
Setrs=（adSchemaTables）
DoUntil
IfRight（"TABLE_NAME"）.Value,1）="$"Then
strSheetName=Mid（"TABLE_NAME"）.Value,1,Len（"TABLE_NAME"）.Value）-1）
ExitDo
EndIf
Loop
Setrs=Nothing
strsql="SELECT*INTO["&strTxtname&"]IN'"&strFolder&"''Text;'FROM"_
&"["&strSheetName&"$"&strRange&"]"
（strsql）
Setcnn=Nothing
EndSub
10，多表汇总
‘08发票.xls
Sub分类汇总（）
Range（"A1:
N5000"）.ClearContents
Setconn=CreateObject（""）
"provider=properties=excel;datasource="&
sq1="select编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,金额,收入,应收,备注from[1月$]"
sq2="select编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,金额,收入,应收,备注from[2月$]"
sq3="select编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,金额,收入,应收,备注from[3月$]"
sq4=sq1&"UNIONALL"&sq2&"UNIONALL"&sq3
sq5="select编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,SUM（金额）,sum（收入）,sum（应收）,备注from（"&sq4&"）GROUPBY编号,日期,发票号,客户,案类,案号,律师,业务量,合作人,项目,备注orderby发票号"
[a65536].End（xlUp）.Offset（1,0）.CopyFromRecordset（sq5）
arr=Array（"编号","日期","发票号","客户","案类","案号","律师","业务量","合作人","项目","金额","收入","应收","备注"）
[a1:
n1]=arr
Setconn=Nothing
Columns（"B:
B"）.Select
="yyyy-mm-dd"
Range（"A2"）.Select
EndSub
11，两工作表查询（ADODB_SQL、按时间段、按客户名）
‘查询.xls（自编宏之五）
‘Excel论坛
DimcnnAs
DimrsAs
DimSqlAsString
DimwbNameAsString,i&,aa$,bb$,cc$,dd$,ee$,Myr%,j%
DimSht1AsWorksheet,Sht2AsWorksheet
Subanrqcx0130（）
SetSht1=Worksheets（"查询表"）
SetSht2=Worksheets（"明细表"）
Range（"c12:
i29"）.ClearContents
dd=[e6]
ee=[f6]
wbName=
Setcnn=New
Withcnn
.Provider=""
.ConnectionString="ExtendedProperties=Excel;"_
&"DataSource="&wbName
.Open
EndWith
Sql="select日期,客户名称,品名及规格,数量,单价,金额,备注from[明细表$]where（日期between#"&dd&"#and#"&ee&"#）"
Setrs=New
Sql,cnn,adOpenKeyset,adLockOptimistic
（12,3）.CopyFromRecordsetrs
[i9].Formula="=sum（h12:
h29）"
Setrs=Nothing
Setcnn=Nothing
Setws=Nothing
EndSub
Subankhcx0130（）
SetSht1=Worksheets（"查询表"）
SetSht2=Worksheets（"明细表"）
Range（"c12:
i29"）.ClearContents
aa=[e8]
wbName=
Setcnn=New
Withcnn
.Provider=""
.ConnectionString="ExtendedProperties=Excel;"_
&"DataSource="&wbName
.Open
EndWith
Sql="select日期,客户名称,品名及规格,数量,单价,金额,备注from[明细表$]where客户名称='"&aa&"'"
Setrs=New
Sql,cnn,adOpenKeyset,adLockOptimistic
（12,3）.CopyFromRecordsetrs
[i9].Formula="=sum（h12:
h29）"
Setrs=Nothing
Setcnn=Nothing
Setws=Nothing
EndSub
12，多条件、有区间统计（ADO－Sql）
升级会员 