今天给大家分享用 ExcelVBA 操作轻便、快速、流行的数据库管理软件SQLite3，进行数据的增删改查。
一、新增数据
录入数据后，点击新增按钮
打开 sqlite3 数据库，可以看到新增的数据，如下图
VBA 代码
Sub Expenses_Insert_Click()
Dim sh1 As Worksheet
Dim strSQL As String, strCnn$
Dim i As Integer
Dim n As Integer
Dim arr()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set sh1 = Sheets(1)
n = sh1.Range("A65536").End(xlUp).Row
If n < 2 Then
MsgBox "Nothing to insert!"
Exit Sub
End If
strCnn = "DRIVER={SQLite3 ODBC Driver};Database=E:\\mydb\\expenses.db;ReadOnly=False;"
cn.Open strCnn
arr = sh1.Range("A2:L" & n)
For i = 1 To UBound(arr)
If sh1.Range("M" & i + 1) = "y" Then
strSQL = "insert into corn_expenses(编号,日期,项目名称,摘要,预支,支出,备注) values( '" & arr(i, 1) & "' , '" & Format(arr(i, 2), "yyyy-mm-dd") & "','" & arr(i, 3) & "' ,'" & arr(i, 4) & "' ,'" & arr(i, 5) & "' ,'" & arr(i, 6) & "','" & arr(i, 7) & "' );"
cn.Execute strSQL
sh1.Range("M" & i + 1) = "Inserted"
Else
MsgBox ("Sorry,请检查数据状态（必须为 y ）")
End If
Next
cn.Close
End Sub
二、删除数据
在 P2 单元格中输入要删除数据的编号，如下图
点击删除按钮，如下图
打开 SQLite3 数据库，可以看到，2号数据已经不存在了。
代码：
Sub Expenses_Delete_Click()
Dim sh1 As Worksheet
Dim strSQL As String
Dim i As Integer
Dim sht_id As String
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set sh1 = Sheets(1)
cn.Open "DRIVER={SQLite3 ODBC Driver};Database=E:\\mydb\\expenses.db"
sht_id = sh1.Range("P2").Value
strSQL = "Delete FROM corn_expenses where 编号 = '" & sht_id & "' ;"
'rs.Open strSql, cnn, adOpenStatic, adLockReadOnly
cn.Execute (strSQL)
MsgBox ("OK,deleted")
cn.Close
End Sub
三、修改数据
假如将1号数据按如下修改，如下图
修改完成后，点击修改按钮
提示数据已经修改，打开数据库查看，如下图
代码
Sub Expenses_Update_Click()
Dim sh1 As Worksheet
Dim strSQL As String, strDate$, item$, description$, advance As Double, expenses As Double, remark$
Dim i As Integer
Dim sht_id As String
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set sh1 = Sheets(1)
cn.Open "DRIVER={SQLite3 ODBC Driver};Database=E:\\mydb\\expenses.db"
sht_id = sh1.Range("P2").Value
strDate = sh1.Range("B2")
item = sh1.Range("C2")
description = sh1.Range("D2")
advance = sh1.Range("E2")
expenses = sh1.Range("F2")
remark = sh1.Range("G2")
strSQL = "SELECT * FROM corn_expenses where 编号= '" & sht_id & "';"
'rs.Open strSql, cnn, adOpenStatic, adLockReadOnly
rs.Open strSQL, cn, 1, 1
If Not rs.EOF Then
strSQL = "Update corn_expenses set 日期='" & strDate & "' ,项目名称 ='" & item & "' ,摘要='" & description & "' ,预支='" & advance & "' , " _
& "支出='" & expenses & "',备注='" & remark & "' where 编号 = '" & sht_id & "' ;"
cn.Execute (strSQL)
MsgBox ("OK,updated")
sh1.Range("M2") = "Updated"
Else
MsgBox ("没有要更新的条目")
End If
cn.Close
End Sub
四、查询数据
点击查询按钮，如下图，可以看到查询结果
我们新增一条数据
再次点击查询，我们可以看到全部数据
代码
Sub Expenses_Query()
Dim sh1 As Worksheet
Dim strSQL As String
Dim i As Integer, n%
Dim rng As Range
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set sh1 = Sheets(1)
With sh1
.Range("A1:M100").Clear
.Range("M1") = "Results"
End With
cn.Open "DRIVER={SQLite3 ODBC Driver};Database=E:\\mydb\\expenses.db"
strSQL = "SELECT 编号,日期,项目名称,摘要,预支,支出,备注 FROM corn_expenses"
'rs.Open strSql, cnn, adOpenStatic, adLockReadOnly
rs.Open strSQL, cn, 1, 1
For i = 1 To rs.Fields.Count
sh1.Cells(1, i) = rs.Fields(i - 1).Name
Next
'cnn.Execute "create table a (a, b, c);" '直接Sql操作
If Not rs.EOF Then
sh1.Range("A2").CopyFromRecordset rs
For i = 1 To rs.RecordCount
sh1.Range("M" & i + 1) = "OK"
Next
Else
sh1.Range("M" & 2) = "NULL"
End If
n = sh1.Range("A65536").End(xlUp).Row
sh1.Range("A1:M1").BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
Set rng = sh1.Range("A1:M" & n)
rng.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
rng.HorizontalAlignment = xlLeft
rng.VerticalAlignment = xlCenter
rs.Close
cn.Close
End Sub
也可以在 P2 单元格输入编号进行查询
在 P3 单元格输入项目名称，点击查询
编号查询代码
Sub Expenses_Query_ID()
Dim sh1 As Worksheet
Dim strSQL As String, sht_id$
Dim i As Integer, n%
Dim rng As Range
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set sh1 = Sheets(1)
With sh1
.Range("A1:M100").Clear
.Range("M1") = "Results"
End With
cn.Open "DRIVER={SQLite3 ODBC Driver};Database=E:\\mydb\\expenses.db"
sht_id = sh1.Range("P2").Value
strSQL = "SELECT * FROM corn_expenses where 编号= '" & sht_id & "';"
'rs.Open strSql, cnn, adOpenStatic, adLockReadOnly
rs.Open strSQL, cn, 1, 1
For i = 1 To rs.Fields.Count
sh1.Cells(1, i) = rs.Fields(i - 1).Name
Next
'cnn.Execute "create table a (a, b, c);" '直接Sql操作
If Not rs.EOF Then
sh1.Range("A2").CopyFromRecordset rs
For i = 1 To rs.RecordCount
sh1.Range("M" & i + 1) = "OK"
Next
Else
MsgBox ("没有找到")
End If
n = sh1.Range("A65536").End(xlUp).Row
sh1.Range("A1:M1").BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
Set rng = sh1.Range("A1:M" & n)
rng.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
rng.HorizontalAlignment = xlLeft
rng.VerticalAlignment = xlCenter
rs.Close
cn.Close
End Sub
项目名称查询代码
Sub Expenses_Query_Product()
Dim sh1 As Worksheet
Dim strSQL As String, product$
Dim i As Integer, n%
Dim rng As Range
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set sh1 = Sheets(1)
With sh1
.Range("A1:M100").Clear
.Range("M1") = "Results"
End With
cn.Open "DRIVER={SQLite3 ODBC Driver};Database=E:\\mydb\\expenses.db"
product = sh1.Range("P3").Value
strSQL = "SELECT * FROM corn_expenses where 项目名称 like '%" & product & "%';"
'rs.Open strSql, cnn, adOpenStatic, adLockReadOnly
rs.Open strSQL, cn, 1, 1
For i = 1 To rs.Fields.Count
sh1.Cells(1, i) = rs.Fields(i - 1).Name
Next
'cnn.Execute "create table a (a, b, c);" '直接Sql操作
If Not rs.EOF Then
sh1.Range("A2").CopyFromRecordset rs
For i = 1 To rs.RecordCount
sh1.Range("M" & i + 1) = "OK"
Next
Else
MsgBox ("没有找到")
End If
n = sh1.Range("A65536").End(xlUp).Row
sh1.Range("A1:M1").BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
Set rng = sh1.Range("A1:M" & n)
rng.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, ColorIndex:=xlAutomatic
rng.HorizontalAlignment = xlLeft
rng.VerticalAlignment = xlCenter
rs.Close
cn.Close
End Sub
好了，至此，已经完成基本的增删改查的功能。