《VBA实例学习.ppt》由会员分享，可在线阅读，更多相关《VBA实例学习.ppt（21页珍藏版）》请在三一办公上搜索。
1、VBA程序与数据库应用实例开发,吕山中学 郭庭楠电话：660139 QQ：10205019,1.添加菜单2.连接数据库及操作3.Excel文件合并,VBA实例学习,学习目的与方法,通过有针对性的实例，让学员初步了解VBA；重点：掌握几个关键性的技能；难点：对数据库的操作；目标：初步能开发一些简单的VBA程序；,实例：制作一个有关数据库应用方面的程序,1.添加菜单2.连接数据库3.新增记录4.查询记录5.修改记录6.删除记录,Sub 添加菜单()Dim myMnu As ObjectWith Application.CommandBars(Worksheet menu bar).Reset Se
2、t myMnu=CommandBars(Worksheet menu bar).Controls._ Add(Type:=msoControlPopup,before:=10)With myMnu.Caption=学生信息档案(&G)End With End With 添加一级命令 添加二级命令End Sub,一、添加菜单,Sub 添加一级命令()With CommandBars(Worksheet menu bar).Controls(学生信息档案(&G).Controls.Add(Type:=msoControlButton,before:=1).Caption=退出(&E).Contro
3、ls(退出(&E).OnAction=退出 End WithEnd Sub,2.添加菜单(一级),Sub 添加二级命令()Dim myTools As CommandBarPopup Dim myCap As Variant Dim myid As Variant Dim i As Byte myCap1=Array(单个信息输入,外部Excel文件导入)With Application.CommandBars(Worksheet menu bar)Set myTools=.Controls(学生信息档案(&G).Controls.Add(Type:=msoControlPopup,befor
4、e:=1)二级菜单命令 With myTools.Caption=录入信息 With.Controls.Add(Type:=msoControlButton).Caption=myCap1(0).OnAction=录入信息 End With With.Controls.Add(Type:=msoControlButton).Caption=myCap1(1).OnAction=外部Excel文件导入 End With End With End With,3.添加菜单(二级),myCap2=Array(导出学生档案(Excel),查询学生档案,修改学生档案,删除学生档案)myid=Array(2
5、81,287,283,285)With Application.CommandBars(Worksheet menu bar)Set myTools=.Controls(学生信息档案(&G).Controls.Add(Type:=msoControlPopup,before:=2)二级菜单命令 With myTools.Caption=信息管理.BeginGroup=True With.Controls.Add(Type:=msoControlButton).Caption=myCap2(0).FaceId=myid(0).OnAction=浏览学生档案.Enabled=False End W
6、ith With.Controls.Add(Type:=msoControlButton).Caption=myCap2(1).FaceId=myid(1).OnAction=查询.Enabled=False End With With.Controls.Add(Type:=msoControlButton).Caption=myCap2(2).FaceId=myid(2).OnAction=修改学生档案.Enabled=False End With With.Controls.Add(Type:=msoControlButton).Caption=myCap2(3).FaceId=myid(
7、3).OnAction=删除学生档案.Enabled=False End With End With End With Set myTools=Nothing,4.1 菜单的重置(1.点击关闭按钮),Sub 删除菜单()Application.CommandBars(Worksheet menu bar).ResetEnd SubPrivate Sub Workbook_WindowDeactivate(ByVal Wn As Window)删除菜单End Sub,4.2 菜单的重置(2.通过退出菜单),Sub 退出()Application.CommandBars(Worksheet men
8、u bar).Reset Application.QuitEnd Sub,二、数据库的操作,新建数据库连接数据库新增数据查询数据修改数据删除数据,4.1 新建数据库,建立一个access数据库 名为：Database.mdb建立一个数据表 stu字段名为,4.2 连接数据库,Dim cn As New ADODB.ConnectionDim rs As New ADODB.RecordsetDim sql As StringSet cn=CurrentProject.Connection cn.Open provider=Microsoft.jet.OLEDB.4.0;data source=
9、&ThisWorkbook.Path&Database.mdb“备注：在VBA的菜单中“工具”“引用”中选上,4.3.1 新增记录（单个档案输入）,Sub input_xs()Dim sql As StringDim rs As New ADODB.RecordsetDim conn As New ADODB.ConnectionSet conn=CurrentProject.ConnectionSet rs=New ADODB.Recordsetconn.Open provider=Microsoft.jet.OLEDB.4.0;data source=&ThisWorkbook.Path&
10、Database.mdbrs.CursorLocation=adUseClientsql=select*from stu where 学号=&Trim(新增学生信息.xb.Text)&rs.Open sql,conn,2,2,adCmdTextIf(rs.EOF=False)Then i=MsgBox(该学号已经存在！是否重新输入？,vbYesNo+vbExclamation,警告)If i=vbYes Then ddbm.Text=cppm.Text=khxm.Text=lxz.Text=ys.Text=ms.Text=ddbm.SetFocus,Else xz.Hide Exit Sub
11、End IfElse rs.AddNew rs.Fields(1)=Trim(xh.Text)rs.Fields(4)=Trim(nj.Text)rs.Fields(5)=Trim(bj.Text)rs.Fields(2)=Trim(xm.Text)rs.Fields(3)=Trim(xb.Text)rs.Fields(6)=Trim(jhr.Text)rs.Fields(7)=Trim(gx.Text)rs.Fields(8)=Trim(zz.Text)rs.Fields(9)=Trim(dh.Text)rs.Update MsgBox 已经成功录入&Trim(xm.Text)&学生的信息！
12、rs.Close conn.Close Set rs=Nothing Set conn=NothingEnd IfEnd Sub,4.3.1 新增记录（外部Excel文件导入）,Sub 外部Excel文件导入()导入单个EXCEL文件Dim myFile As VariantDim AppAccess As New Access.ApplicationDim wbPath As StringmyFile=Application.GetOpenFilename(Excel Files(*.xls),*.xls)If VarType(myFile)=vbBoolean Then MsgBox Ca
13、nCel by User!Exit SubEnd IfApplication.ScreenUpdating=FalsewbPath=ThisWorkbook.Path&With AppAccess.OpenCurrentDatabase wbPath&Database.mdb,True.DoCmd.TransferSpreadsheet acImport,acSpreadsheetTypeExcel9,stu,myFile,True.CloseCurrentDatabaseEnd WithApplication.ScreenUpdating=FalseMsgBox myFile&Chr(10)
14、&“导入数据成功！Set AppAccess=NothingEnd Sub,4.4.1 查询记录（1）(将ACCESS数据库中数据导入到EXCEL中),For col=0 To rs.Fields.Count-1Sheet1.Cells(1,col+1)=rs.Fields(col).NameNext col 导出数据Row=2Do While Not rs.EOF For col=0 To rs.Fields.Count-1 Sheet1.Cells(Row,col+1)=rs.Fields(col)Next col Row=Row+1 rs.MoveNextLooprs.CloseShee
15、t1.Columns.AutoFit 设置列宽Sheet1.ActivateEnd Sub,Sub 浏览学生档案()Dim col As IntegerDim sql As StringDim rs As New ADODB.RecordsetDim conn As New ADODB.ConnectionSet conn=CurrentProject.ConnectionSet rs=New ADODB.RecordsetSheet1.ActivateSheet1.Range(A2:Z65536).ClearContents 清空指定区域单元格内的数据conn.Open provider=M
16、icrosoft.jet.OLEDB.4.0;data source=&ThisWorkbook.Path&Database.mdbrs.CursorLocation=adUseClientsql=select*from sturs.Open sql,conn,adOpenKeyset,adLockOptimistic 获取数据集导出字段名称,4.4.2 查询记录（2）(将ACCESS数据库中指定的数据显示出来),conn.Open provider=Microsoft.jet.OLEDB.4.0;data source=&ThisWorkbook.Path&Database.mdbrs.Cu
17、rsorLocation=adUseClientsql=select*from stu where 学号=&修改删除学生信息.xh&rs.Open sql,conn,adOpenDynamic,adLockOptimistic,adCmdText,4.5 修改记录,Dim sql As StringDim rs As New ADODB.RecordsetDim conn As New ADODB.ConnectionSet conn=CurrentProject.ConnectionSet rs=New ADODB.Recordsetconn.Open provider=Microsoft.
18、jet.OLEDB.4.0;data source=&ThisWorkbook.Path&Database.mdbrs.CursorLocation=adUseClientsql=update stu set 年级=&修改学生信息.nj&,班级=&修改学生信息.bj&,姓名=&修改学生信息.xm&,性别=&修改学生信息.xb&,监护人=&修改学生信息.jhr&,与监护人关系=&修改学生信息.gx&,住址=&修改学生信息.zz&,电话=&修改学生信息.dh&where 学号=&修改学生信息.xh&rs.Open sql,conn,adOpenKeyset,adLockOptimisticconn
19、.CloseMsgBox 学生信息已修改记录成功!,4.6 删除记录,Dim sql As StringDim rs As New ADODB.RecordsetDim conn As New ADODB.ConnectionSet conn=CurrentProject.ConnectionSet rs=New ADODB.Recordseti=MsgBox(确定要删除这个学生的所有信息吗？,vbYesNo+vbExclamation,警告)If i=vbYes Then conn.Open provider=Microsoft.jet.OLEDB.4.0;data source=&This
20、Workbook.Path&Database.mdb rs.CursorLocation=adUseClient sql=delete from stu where 学号=&删除学生信息.xh&rs.Open sql,conn,adOpenKeyset,adLockOptimistic conn.CloseMsgBox 学生信息删除成功!End If,Sub 合并()Application.ScreenUpdating=False Dim lj,dirname,nm Dim a As Long Dim i As Long lj=ActiveWorkbook.Path nm=ActiveWork
21、book.Name dirname=Dir(lj&*.xls)Do While dirname If dirname nm Then Workbooks.Open Filename:=lj&dirname a=Sheets.Count 读当前工作薄中的所有的工作表 Workbooks(nm).Activate For i=1 To a Workbooks(dirname).Sheets(i).UsedRange.Copy Range(a65536).End(xlUp).Offset(1,0)复制新打开的工作簿的第一个工作表的已用区域到rng Next i Workbooks(dirname).Close False End If dirname=Dir LoopEnd Sub,三、合并多个excel文件（数据汇总）,谢谢！,
