Sub 连接数据库()
'第一步：告诉电脑，我们要用ADO，就是引用ADO工具
'引用法
'工具--引用--Microsoft Activex Date Objects 6.1 Library
'工具--引用--Microsoft Activex Date Objects Recordset 6.0 Library
'引用后再声明:
'Dim conn As New Connection 声明链接对象
'Dim rst As New Recordset 声明记录集对象
'创建法
'使用CreateObject函数创建
'Set cnn = CreateObject("adodb.connection") '创建ado对象
'Set rst = CreateObject("ADODB.recordset") '创建记录集

''第二步：创建连接对象
''2-1：给连接对象取名字
'Dim con As ADODB.Connection     '声明对象变量
''2-2：创建对象变量并赋值
'Set con = New ADODB.Connection  '创建对象变量
Dim con As New ADODB.Connection

'第三步：建立Access数据库的连接
'con.Open "provider=Microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.Path & "\学生管理.accdb" '一条写法
'建立Excel的连接
'con.Open "provider=Microsoft.ace.oledb.12.0;extended properties
=excel 12.0;data source="&ThisWorkbook.Path & "\数据.xlsx" '一条写法
With con '多条写法
    .Provider = "Microsoft.ace.oledb.12.0" '驱动程序的提供者及版本
(2007以上2003 8.0)
    .ConnectionString = ThisWorkbook.Path & "\学生管理.accdb" '连接
字符串数据源的完整路径
    .Open '打开数据库
End With
MsgBox "连接成功"
End Sub
 
Option Explicit
'SQL:结构化查询语言，数据定义、数据操纵
'数据定义：表的创建、表的删除等功能
'数据操纵：对记录的插入、删除、更新、查询

Sub 插入记录()
'1、定义、创建连接变量
Dim con As New ADODB.Connection

'2、建立数据库的连接
con.Open "provider=microsoft.ace.oledb.12.0;data source="&
ThisWorkbook.Path & "\学生管理.accdb"

'3、插入记录：insert into 表名(列1,列2,...) values(值1,值2,...)
    '当向表中所有字段添加记录时，可以省略表名后面（）里的内容
    '表名和values有三个一致：数量一致、顺序一致、类型一致
    
'3-1：书写SQL命令
Dim sql0 As String, sql1 As String, arr(), i As Integer
sql0 = "insert into 院系(系号,系名,电话) values('A07','人文学院',
'9999')"
sql1 = "insert into 院系 values('A11','明文学院','6666')" '当向表
中所有字段添加记录时，可以省略表名后面（）里的内容
arr = Array(sql0, sql1)
'3-2：执行SQL命令
For i = 0 To UBound(arr)
    con.Execute (arr(i))
Next i
'4、释放变量空间
con.Close       '关闭连接
Set con = Nothing   '释放变量
End Sub
 
Sub 删改记录()
'1、定义、创建连接变量
Dim con As New ADODB.Connection

'2、建立数据库的连接
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.Path & "\学生管理.accdb"

''3、删除记录：delete from 表名 [where 条件]，如果忽略条件，那么删除所有记录
Dim sql As String
'sql = "delete from 院系"
'sql = "Delete from 院系 where 系名='明文学院'"
'sql = "Delete from 院系 where 系号='A07'"

'更新记录：update 表名 set 字段1=值1, 字段2=值2 [where 条件]，如果忽略条件，
那么更新所有记录
'Dim sql As String
'sql = "update 院系 set 电话='9999' where 系名='明文学院'"
'sql = "update 学生 set 班级='1班',研究方向='会计' where 性别='男'"

'在SQL语句中使用变量
Dim str As String, bj As String '用于保存用户输入的条件
str = InputBox("输入性别", "提示")
bj = InputBox("输入班级", "提示")
'sql = "update 学生 set 班级='2班' where 性别='" & str & "'"
sql = "update 学生 set 班级='" & bj & "' where 性别='" & str & "'"
sql = "update 学生 set 性别='女'"
'执行SQL命令
con.Execute (sql)
'4、释放变量空间
con.Close       '关闭连接
Set con = Nothing   '释放变量
End Sub
 
Sub SQL简单查询()
'1、定义、创建连接变量
Dim con As New ADODB.Connection

'2、建立数据库的连接
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.Path & "\学生管理.accdb"

'3、查询记录：select 字段列表 from 表名 [where 条件]
    '从某个表当中提取出满足某个条件的字段值
'    from 表名->select:提取-->[where 条件]-->字段列表的值
Dim sql As String
'3-1：查询表中的全部字段：*
sql = "select * from 院系"
'sql = "select 系号,系名 from 院系"
'sql = "select 系号,系名 from 院系 where 系名='明文学院' AND 系号='A11'"
'sql = "select 系号,系名 from 院系 where 系名='明文学院' OR 系号='A11'"

Dim rs As New ADODB.Recordset  '创建记录集对象
'执行SQL命令之后，提取到的数据会被加载到内存中
Set rs = con.Execute(sql)       '将记录集存到rs中

'MsgBox rs.Fields.Count          '字段个数
Sheets("演示").Range("a1").CurrentRegion.Clear '清空原有数据

'获取字段名，使用循环(0 到 字段个数-1
Dim i As Integer
For i = 0 To rs.Fields.Count - 1
    Sheets("演示").Cells(1, i + 1) = rs.Fields(i).Name
Next i

'将记录集rs中的数据返回到工作表
Sheets("演示").Range("A2").CopyFromRecordset rs

'4、释放对象变量空间
rs.Close: Set rs = Nothing '关闭并释放记录集对象
con.Close: Set con = Nothing '关闭并释放连接对象
End Sub

将vba联接数据库，以控件展示数据

Sub 打开窗口()
    frmEmpInfo.Show
End Sub
列表框：
Option Explicit
Dim con As ADODB.Connection
 '声明连接对象变量
Dim rs As ADODB.Recordset
 '声明记录集对象变量

'关闭按钮：释放变量空间、
关闭数据库连接、关闭窗体
Private Sub cmdClose_Click()
    con.Close
    Set rs = Nothing
    Set con = Nothing
    Unload Me
End Sub
 
 
'当窗体加载时，填写lstBM这个列表框的内容
Private Sub UserForm_Initialize()
'建立数据库的连接
Set con = New ADODB.Connection
With con
    .Provider = "microsoft.ace.oledb.12.0"
    .ConnectionString = "data source=" & _
    ThisWorkbook.Path & "\学生管理.accdb"
    .Open
End With

'提取不重复的部门名称
Dim sql As String           '定义命令字符串变量
sql = "select distinct 部门 from 员工"
Set rs = New ADODB.Recordset    '创建记录集对象
rs.Open sql, con, adOpenKeyset, 
   adLockOptimistic

'将记录集中的部门名称显示到lstBM列表框中
Dim i As Integer
With lstBM
    .Clear
    For i = 1 To rs.RecordCount
      .AddItem rs("部门")
      rs.MoveNext  '将记录集中的指针指向下一条记录
    Next i
End With
rs.Close
End Sub
   
'一级选择：鼠标选择某个部门，相当于单击列表框，单击列表框，查询所选部门的员工
'提取员工的编号和姓名，避免姓名重复的问题
Private Sub lstBM_Click()
Dim sql As String, i As Integer
sql = "select 编号,姓名 from 员工 where 部门='" &lstBM.Value& "' order by 编号"
rs.Open sql, con, adOpenKeyset, adLockOptimistic
With lstEmp
    .Clear
    For i = 1 To rs.RecordCount
        .AddItem rs("编号") & Space(2) & rs("姓名") 'space(n)，用于产生n个空格
        rs.MoveNext
    Next i
End With
rs.Close
End Sub
二级菜单选择：
Private Sub lstEmp_Click()
Dim arr, i As Integer
Dim sql As String
sql = "select * from 员工 where 编号=
'" & Left(lstEmp.Value, 6) & "'"
rs.Open sql, con, adOpenKeyset, adLockOptimistic
'将每个字段的值存到相应的控件里
arr = Array("txtID", "txtName", "txtNumber", "txtBM", "txtAge",
 "txtZW", "txtDate", "txtAddress", "txtMail", "txtInfo")
For i = 0 To UBound(arr)
    Me.Controls(arr(i)).Value = rs.Fields(i)
Next i  me指当前窗体，controls指控件集合
rs.Close
End Sub