他山之石——VBA数据库操作

继续学习VBA。在实际工作中，发现用Excel连接Oracle数据库有时有问题：

1. 在Toad中运行良好的脚本，到了Excel query里就有问题了（不知是否因为脚本中包含了一些聚合函数的原因）。

2. 在Excel中连接数据库，刷新数据的速度很慢。Toad中查询数据并导出到Excel用时两分钟，在Excel中直接刷新耗时可达20分钟。

当然，优点是多了一条获取数据的路径（用户无需安装Toad等数据库客户端软件，而是直接将Excel作为客户端）。这也体现了Excel功能的全面性。

'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?

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


'一、Connection对象
  '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 = "Provider=MSDASQL;Driver={SQL Server};Server=" & Path & ";Database=" & strDataName
        '4 Oracle数据库
             'strDriver= "Provider=madaora;Data Source=MyOracleDB; User Id=UserID; Password=Password"

  '2 执行sql语句
    '.Execute SQL
    '增加新表格：.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 '添加记录后要更新
    '3 修改记录
       'rst.Update 字段数组, 值或数组
    '4 删除记录
       'rst.delete
    '5 在记录中循环
       'BOF 在记录的最前面
       'EOF 在记录的结尾
       'GetRows(默认值-1,Start, 字段)'Start 0从当前记录开始,1从第一条记录,2从最后一条记录开始

'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("李楠", 25, "男")
'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("年龄") = 23
    rst.Fields("性别") = "女"
rst.Update
cnn.Close
Set cnn = Nothing
MsgBox "添加成功"
End Sub


'数据库中查找记录,可以执行含where条件判断的Select语句.符合条件的可能只有一条记录.也可能是多条记录
'单个记录查找

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 < 1 Then
        MsgBox "找不到该姓名"
        GoTo 100
    End If
  Debug.Print "年龄:" & rst.Fields("年龄")
  Debug.Print "性别:" & rst.Fields("性别")
' MsgBox "查找成功"
100:
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 < 1 Then
        MsgBox "找不到该姓名"
        GoTo 100
    End If
  Debug.Print "年龄:" & rst.Fields("年龄")
  Debug.Print "性别:" & rst.Fields("性别")
' MsgBox "查找成功"
100:
rst.Close
conn.Close
Set rst = Nothing
Set conn = Nothing
End Sub

'SQL语句中delete语句可以删除符合条件的记录
 'Delete * from 数库表 where 条件
' 注:Delete语句不支持Excel数据库删除操作,所以要想删除Excel中的数据,只能用其他方法,如打开后删除.

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
Call 查
End Sub

Sub 查()
 Call FindX("李楠")
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
Call 查
End Sub

'修改记录可以用两种方式实现
  '1 用update语句
     'Update
  '2 用Recordset对象的update方法
     'Recordset对象.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 = 28
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 = 19
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

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 = 1 To UBound(arr, 1)
    Debug.Print arr(x, 1) & "," & arr(x, 2)
 Next x
 rst.Close
 conn.Close
 Set rst = Nothing
 Set conn = Nothing
 
End Sub