VBA-数据库操作

基本概念

1 怎么样才能操作数据库？
使用ADO建立和数据库的连接，然后用ADO对象和sql语言对数据库进行操作。

2 SQL是什么?
SQL（Structured Query Language)是一种查询语言，可以查询、更新数据库中的数据。

3 SQL可以查询哪些数据库?
SQL是一种通用的查询语言,可以查询EXCEL,ACCESS,SQL SERVER等各种数据库

4 ADO是什么？
ADO是新的数据库存取技术，可以建立与各数据库库的连接，也可以对数据库数据进行添加、更新、删除等操作

5 我们学习SQL+ADO访问数据库有什么用处?
　　1 可以在不打开EXCEL文件的情况下,从文件中提取数据.
　　2 可以从建立连接的专业软件数据库中提取数据.如财务软件等.

6 怎么使用ADO?

　　1) 引用法

工具--引用---Microsoft Activex..D...O"
引用后再声明: Dim conn As New Connection 声明链接对象
Dim rst As New Recordset 声明记录集对象
2) 创建法
使用CreateObject函数创建
Set conn = CreateObject("adodb.connection") '创建ado对象
Set rst = CreateObject("ADODB.recordset") '创建记录集

ADO的基本对象

一、Connection对象

数据库连接字符串(在类模块中定义)如下:

Property Get excel_driver(datasource)
    'Excel数据库 = "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.path & "/Database/exceldata.xls"
    excel_driver = "provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & datasource
End Property

Property Get access_driver(datasource)
    'Access数据库 = "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.path & "/Database/AccessData.mdb"
    access_driver = "provider=Microsoft.jet.OLEDB.4.0;data source=" & datasource
End Property

Property Get mysql_driver(host, port, database, uid, pwd)
    mysql_driver = "Driver={MySQL ODBC 8.0 Unicode Driver};Server=" & host & ";Port=" & port & ";Database=" & database & ";Uid=" & uid & ";Pwd=" & pwd & ";OPTION=3;"
End Property

Property Get sqlserver_driver(id, database, uid, PassWordChr)
    sqlserver_driver = "Provider=sqloledb;Server=" & id & ";Database=" & database & ";Uid=" & uid & ";Pwd=" & PassWordChr & ";"
End Property

Property Get sqlite_driver(database)
    sqlite_driver = "Driver={SQLite3 ODBC Driver};Database=" & database
End Property

1 建立和数据库的连接
.Open
Dim conn As New Connection
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.Path & "/Database/exceldata.xls"
Conn.Open:打开数据库的连接
provider=microsoft.jet.oledb.4.0 数据库引擎版本
extended properties=excel 8.0 连接的是Excel8.0版本(excel2000以后的版本),Excel不是标准的数据库格式,所以要设置扩展属性
data source=" & ThisWorkbook.Path & "/数据库.xls" 数据库路径

************以下是连接其他数据库或文件的字符串表达式*********************************
1) Mysql数据库
strDriver = "Provider=SQLOLEDB;DataSource=" & Path & ";Initial Catolog=" & strDataName
2) TXT文件
strDriver = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=text;IMEX=1;HDR=NO;FMT=Delimited;;Data Source=" & Path
3) MSSQL数据库
strDriver = "Driver={MySQL ODBC 8.0 Unicode Driver};Server=" & host & ";Port=" & port & ";Database=" & database & ";Uid=" & uid & ";Pwd=" & pwd & ";OPTION=3;"
4) Oracle数据库
strDriver= "Provider=madaora;Data Source=MyOracleDB; User Id=UserID; Password=Password"

2 执行sql语句
.Execute SQL　　　　# 返回的是Recordset对象
增加新表格：.Execute "Create 表格名 字段和属性"
增加新记录：.Execute "Insert into 表名 (字段1, 字段2,... 字段n) VALUES(值1,值2,... 值n)"
删除记录： .Execute "Delete from 表名 where 条件
修改旧记录：.Execute "Update 表名称 SET 列1 = 新值,列2=新值 WHERE 列名称 = 某值
筛选记录: .Execute "Select 字段 from 表 where 条件

二、Recordset对象

作用 打开记录集操作记录
1 打开游标(记录集)
rst.Open sql或command语句等, 已打开的conn链接,
2 添加新记录
AddNew 单个字段或数组,单个值或数组

或

rst.AddNew 添加新的记录
rst.Fields("姓名") = "伍天明" 　　Fields("字段名")表示某列的记录
rst.Fields("年龄") = 28
rst.Fields("性别") = "男"
rst.Update 添加记录后要更新

'1 使用.Execute 执行 Insert 语句
Sub 添加1()
    Dim conn As New Connection
    Dim sql As String
    Dim data As New 数据库
    conn.Open data.Excel数据库
    sql = "Insert into [Sheet1$] (姓名, 年龄, 性别) VALUES('张三', 35, '男')"
    conn.Execute sql
    conn.Close
    Set conn = Nothing
End Sub
'2 使用AddNew方法添加记录
Sub 添加()
    Dim conn As New Connection
    Dim rst As New Recordset
    'Set conn = CreateObject("adodb.connection") '创建ado对象
    'Set rst = CreateObject("ADODB.recordset") '创建记录集
    Dim data As New 数据库
    conn.Open data.Excel数据库
    rst.Open "select *  from [Sheet1$]", conn, adOpenForwardOnly, adLockOptimistic
    rst.AddNew Array("姓名", "年龄", "性别"), Array("李楠", , "男")
    'rst.AddNew '添加新的记录
    '    rst.Fields("姓名") = "伍天明w" 'Fields("字段名")表示某列的记录
    '    rst.Fields("年龄") = 28
    '    rst.Fields("性别") = "男"
    'rst.Update '添加记录后要更新
    rst.Close '关闭记录集
    conn.Close '关闭与数据库的链接
    Set rst = Nothing '释放对象
    Set conn = Nothing '释放对象
    MsgBox "已输入到数据库"
End Sub

Sub 添加到access()
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim sq1 As String
    Dim data As New 数据库
    cnn.Open data.Access数据库
    '链接方法同excel数据链接
    sq1 = "Select * from 员工" '从员工表中查询
    rst.Open sq1, cnn, adOpenKeyset, adLockOptimistic
    rst.AddNew
    rst.Fields("姓名") = "李楠"
    rst.Fields("年龄") =
    rst.Fields("性别") = "女"
    rst.Update
    cnn.Close
    Set cnn = Nothing
    MsgBox "添加成功"
End Sub

3 修改记录
rst.Update 字段数组, 值或数组

Sub 记录修改()
    'Set conn = CreateObject("adodb.connection")
    Dim conn As New Connection
    Dim rst As New Recordset
    Dim sql As String
    Dim nl As String, xb As String, xm As String
    xm = "唐七七"
    xb = "男"
    nl =
    conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.path & "/Database/exceldata.xls"
    sql = "update [Sheet1$] set 年龄=" & nl & ",性别='" & xb & "' where 姓名='" & xm & "'"
    conn.Execute sql
    conn.Close
    Set conn = Nothing
    MsgBox "数据库的记录已修改"
End Sub

Sub 记录修改2()
    Dim conn As New Connection
    Dim rst As New Recordset
    Dim sql As String
    Dim nl As String, xb As String, xm As String
    xm = "唐七七"
    xb = "女"
    nl =
    conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.path & "/Database/exceldata.xls"
    sql = "Select * from [sheet1$] where 姓名='" & xm & "'"
    rst.Open sql, conn, adOpenKeyset, adLockOptimistic
    rst.Update Array("性别", "年龄"), Array(xb, nl)
    rst.Clone
    conn.Close
    Set rst = Nothing
    Set conn = Nothing
    MsgBox "数据库的记录已修改"
End Sub

4 删除记录
rst.delete

Sub ADO删除方法()
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim sq1 As String
    Dim data As New 数据库
    cnn.Open data.Access数据库
    sq1 = "delete  from 员工 where 姓名='" & "李楠" & " '"
    cnn.Execute sq1
    MsgBox "删除成功"
    cnn.Close
    Set cnn = Nothing
End Sub

Sub ADO删除方法2()
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim sq1 As String
    Dim data As New 数据库
    cnn.Open data.Access数据库
    sq1 = "select * from 员工 where 姓名='" & "李楠" & " '"
    rst.Open sq1, cnn, adOpenForwardOnly, adLockOptimistic
    rst.Delete
    MsgBox "删除成功"
    cnn.Close
    Set cnn = Nothing
End Sub

5 在记录中循环
BOF 在记录的最前面
EOF 在记录的结尾
GetRows(默认值-1,Start, 字段)Start 0从当前记录开始,1从第一条记录,2从最后一条记录开始

Sub 在记录之间循环()
    Dim conn As New Connection
    Dim rst As New Recordset
    Dim data As New 数据库
    Dim x
    conn.Open data.Excel数据库
    rst.Open "select * from [Sheet1$] where val(年龄)>25", conn, adOpenKeyset, adLockOptimistic
    For x = 1 To rst.RecordCount
        If rst.EOF Then
            MsgBox "已到最后一条记录"
        Else
            Debug.Print rst.Fields("姓名") & rst.Fields("年龄")
            rst.MoveNext
        End If
    Next x
    rst.Close
    conn.Close
    Set rst = Nothing
    Set conn = Nothing

End Sub

Sub 在记录之间循环2()
    Dim conn As New Connection
    Dim rst As New Recordset
    Dim data As New 数据库
    Dim x, arr, arr1
    conn.Open data.Excel数据库
    rst.Open "select * from [Sheet1$] where val(年龄)>25", conn, adOpenKeyset, adLockOptimistic
    'MsgBox rst.RecordCount
    arr1 = Array("姓名", "年龄")
    arr = Application.Transpose(rst.GetRows( - 1, 1, arr1))
    For x =  To UBound(arr, )
        Debug.Print arr(x, ) & "," & arr(x, )
    Next x
    rst.Close
    conn.Close
    Set rst = Nothing
    Set conn = Nothing

End Sub

记录查找

Sub 筛选()
    Dim conn As New Connection
    Dim data As New 数据库
    conn.Open data.Excel数据库
    Range("a1:c100") = ""
    Range("a2").CopyFromRecordset conn.Execute("select * from [sheet1$] where val(年龄) > 25")
    conn.Close
    Set conn = Nothing
End Sub
Sub 查找()
    Set conn = CreateObject("adodb.connection")
    Set rst = CreateObject("ADODB.recordset")
    Dim data As New 数据库
    conn.Open data.Excel数据库
    rst.Open "select *  from [Sheet1$] " 'where 姓名='李楠2'", conn, adOpenKeyset, adLockOptimistic
    If rst.RecordCount <  Then
        MsgBox "找不到该姓名"
        Goto
    End If
    Debug.Print "年龄:" & rst.Fields("年龄")
    Debug.Print "性别:" & rst.Fields("性别")
    ' MsgBox "查找成功"

    rst.Close
    conn.Close
    Set rst = Nothing
    Set conn = Nothing
End Sub

Sub FindX(xingming As String)
    Set conn = CreateObject("adodb.connection")
    Set rst = CreateObject("ADODB.recordset")
    Dim data As New 数据库
    conn.Open data.Access数据库
    rst.Open "select *  from 员工 where 姓名='" & xingming & "'", conn, adOpenKeyset, adLockOptimistic
    If rst.RecordCount <  Then
        MsgBox "找不到该姓名"
        Goto
    End If
    Debug.Print "年龄:" & rst.Fields("年龄")
    Debug.Print "性别:" & rst.Fields("性别")
    ' MsgBox "查找成功"

    rst.Close
    conn.Close
    Set rst = Nothing
    Set conn = Nothing
End Sub

sql应用

一 按条件筛选

'按条件筛选--多个条件
'用and,OR连接
Sub 按条件筛选5()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select * from [sheet1$] Where 出库日期 between  #2005-1-4# and #2005-1-10# and 销售单价>100"
    data.执行筛选 data.Excel数据库, sql
End Sub
''按条件筛选--模糊条件
'%表示任意多个字符,_(下划线)表示单个占位符
Sub 按条件筛选6()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select * from [sheet1$] Where 物品名称 like '%扶手%'"
    data.执行筛选 data.Excel数据库, sql
End Sub
''按条件筛选--插入变量
Sub 按条件筛选7()
    Dim sql As String
    Dim data As New 数据库
    Dim sr
    sr = "挡泥板"
    sql = "Select * from [sheet1$] Where 物品名称 ='" & sr & "'"
    data.执行筛选 data.Excel数据库, sql
End Sub
''按条件筛选--在字符串组里
Sub 按条件筛选8()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select * from [sheet1$] Where 物品名称 in('车衣','扶手箱')"
    data.执行筛选 data.Excel数据库, sql
End Sub
''按条件筛选--借用函数
Sub 按条件筛选9()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select * from [sheet1$] Where left(物品代码,3)='028'"
    data.执行筛选 data.Excel数据库, sql
End Sub

二 筛选方式

Option Explicit

'筛选方式是指结果的样式

'1 筛选全部字段
'*表示全部字段
Sub 筛选全部字段()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select * from ChuKu"
    data.执行筛选 data.Access数据库, sql
End Sub

'2 筛选指定字段
'在from前面列出要显示的所有字段,如果要跳过的用""""
Sub 显示指定字段()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select """",出库日期,"""",物品代码,"""",规格,单位 from ChuKu"
    data.执行筛选 data.Access数据库, sql
End Sub

'3 筛选不重复的
'Distinct 字段名 筛选不重复的记录
Sub 不重复筛选()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select Distinct """",物品代码 from ChuKu"
    data.执行筛选 data.Access数据库, sql
End Sub

'4 筛选前N个
'TOP N 只显示前N个记录
Sub 筛选前10个() '按个数筛选
    Dim sql As String
    Dim data As New 数据库
    sql = "Select top 10 * from ChuKu"
    data.执行筛选 data.Access数据库, sql
End Sub

'Top N percent 可以显示前百分之N的记录
Sub 筛选百分之N() '按百分比筛选
    Dim sql As String
    Dim data As New 数据库
    sql = "Select top 30 Percent * from ChuKu"
    data.执行筛选 data.Access数据库, sql
End Sub

'5 格式化显示的结果
'可以对筛选的字段用函数进行进一步的处理和格式化
Sub 格式化字段() '按百分比筛选
    Dim sql As String
    Dim data As New 数据库
    sql = "Select  ID,Format(出库日期,""yyyy-mm-dd"") from ChuKu"
    data.执行筛选 data.Access数据库, sql
End Sub

'6 对筛选后的结果排序

Sub 排序() '
    'Desc降序
    'Asc升序
    Dim sql As String
    Dim data As New 数据库
    sql = "Select  * from ChuKu Order by 出库日期 asc,销售单价 desc"
    data.执行筛选 data.Access数据库, sql
End Sub
Sub 筛选销售数量前10() '
    Dim sql As String
    Dim data As New 数据库
    sql = "Select  Top 10 * from ChuKu Order by 出库日期 asc,销售单价 desc"
    data.执行筛选 data.Access数据库, sql
End Sub

'7 分组显示
'Group by 可以配合函数进行分组求和,分组求最大值等.
Sub 分组() '
    Dim sql As String
    Dim data As New 数据库
    sql = "Select  """","""",物品代码,"""","""","""",sum(出库数量) from ChuKu group by 物品代码"
    data.执行筛选 data.Access数据库, sql
End Sub
Sub 按条件显示分组记录() '
    Dim sql As String
    Dim data As New 数据库
    sql = "Select  """","""",物品代码,"""","""","""",sum(出库数量) from ChuKu group by 物品代码 HAVING sum(出库数量)>=3"
    data.执行筛选 data.Access数据库, sql
End Sub

三 SQL函数应用

Option Explicit

'1 SUM函数求和,count计数
Sub 求和()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select sum(出库数量),count(出库数量) from ChuKu where 物品代码='0270001'"
    data.执行筛选 data.Access数据库, sql
End Sub

'2 left,right,mid,instr,format文本函数
Sub 文本()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select 物品代码, ""左三位:"" & left(物品代码,3),right(物品代码,4),mid(物品代码,2,2),instr(物品代码,""1"") from ChuKu"
    data.执行筛选 data.Access数据库, sql
End Sub

'3 year,month,day,datediff,DateSerial日期函数
Sub 日期()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select 出库日期, year(出库日期),month(出库日期),day(出库日期),DateDiff(""m"",出库日期,now) from ChuKu"
    data.执行筛选 data.Access数据库, sql
End Sub
'4 max,min,first,last 最值函数
Sub 最小值()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select 物品名称,min(销售金额) from ChuKu group by 物品名称"
    data.执行筛选 data.Access数据库, sql
End Sub

Sub 最新值()
    Dim sql As String
    Dim data As New 数据库
    sql = "Select 物品名称,last(销售金额) from ChuKu group by 物品名称"
    data.执行筛选 data.Access数据库, sql
End Sub

四 多表查询

'Union (AlL) 多个select查询结果合并在一起
Sub 合并工作表数据()
    Dim data As New 类1
    Dim sql As String
    sql = "select  * from [Sheet1$a:c] union all select * from [sheet2$a:c]"
    data.执行筛选 sql, "a2"
End Sub

Sub 合并工作表数据2()
    Dim data As New 类1
    Dim sql As String
    sql = "select  * from [Sheet1$a:c] union  select * from [sheet2$a:c]"
    data.执行筛选 sql, "a2"
End Sub

'查找两个表中相同的
'Select 字段 from 表1,表2 where 表1.字段=表2.字段
Sub 列出相同()
    Dim data As New 类1
    Dim sql As String
    sql = "select [Sheet1$a:c].* from [Sheet1$a:c],[Sheet2$a:c] where [Sheet1$a:c].类别=[Sheet2$a:c].类别"
    data.执行筛选 sql, "a2"
End Sub
'Select 字段 from 表1 Inner Join 表2 on 条件
Sub 列出相同2()
    Dim data As New 类1
    Dim sql As String
    sql = "select [Sheet1$].*,[sheet2$].库别 from [Sheet1$] Inner Join [sheet2$] on [Sheet1$].类别=[sheet2$].类别"
    data.执行筛选 sql, "a2"
End Sub

'两表汇总
Sub 汇总()
    Dim data As New 类1
    Dim sql As String
    Dim sq As String
    sql = "select * from [sheet1$a:c] union all select * from [sheet2$a:c]"
    sq = "select 类别,sum(数量),sum(金额) from (" & sql & ") group by 类别"
    data.执行筛选 sq, "a2"
End Sub

'
Sub 合并()
    Dim data As New 类1
    Dim sql As String
    sql = "select [Sheet1$].*,[sheet2$].库别 from [Sheet1$]  left Join [sheet2$] on [Sheet1$].类别=[sheet2$].类别"
    data.执行筛选 sql, "a2"
End Sub

'JOIN: 如果表中有至少一个匹配，则返回行
'LEFT JOIN: 即使右表中没有匹配，也从左表返回所有的行
'RIGHT JOIN: 即使左表中没有匹配，也从右表返回所有的行
'FULL JOIN: 只要其中一个表中存在匹配，就返回行,可惜的是在EXCEL VBA中不支持

自定义SQL拼接函数

Sub excelTest()
    Dim conn As New Connection
    conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0';data source=" & ThisWorkbook.FullName
    sql = parse_sql("select * from [test$] where age=?", Array(Range("D1")))
    Set rst = conn.Execute(sql)

    Range("A1").CopyFromRecordset rst

    conn.Close
    Set rst = Nothing
    Set conn = Nothing
End Sub

Function parse_sql(sql, params)
    arr = Split(sql, "?")
    temp = ""
    For i =  To UBound(arr)
        If i < UBound(arr) Then
            If IsNumeric(params(i)) Then
                temp = temp & arr(i) & params(i)
            Else
                temp = temp & arr(i) & "'" & params(i) & "'"
            End If
        End If
    Next i
    parse_sql = temp
End Function

end