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("李楠", 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

 

 

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 = 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

 

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 = 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

 

 

記錄查找

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應用

一 按條件篩選

'按條件篩選--多個條件
'用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 = 0 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