Excel VBA 对 Access增删改查代码分享

xmh850216 · 发表于 2019-8-16 12:25

本帖最后由 xmh850216 于 2019-8-16 14:07 编辑

结合官方的文档，前人的经验和自己工作中的实例。整理了一篇关于VBA里操控Access的例子。和大家分享.
前提：

本例使用的是Office 2016

添加ADO Lib引用

快捷键Alt+F11进入VBE Tools>References...>

勾选 Microsoft ActiveXData Object

创建链接

Function Connect(dbPath As String) As ADODB.Connection
Set objConn = New ADODB.Connection
With objConn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Data Source") = dbPath
.Properties("Persist Security Info") = False
.Open
End With
Set Connect = objConn
Debug.Print "Connection established..."
End Function

复制代码

关闭链接

Sub CloseConnection(objConn As ADODB.Connection)
On Error Resume Next
objConn.Close
Debug.Print "Connection closed..."
Set objConn = Nothing
End Sub

复制代码

增/删/改/查基础程序

Sub Insert_Data(strSQL as String)
'示例strSQL = "INSERT INTO TableName(Column_Name1, Columns_Name2) Values('Value1', 'Value12')"
'需要在使用的时候传入strSQL查询语句
objCon.Execute strSQL
End Sub
Sub Delete_Data(strSQL as String)
'示例strSQL = "DELETE FROM TableName WHERE Column_Name1='Value1'"
'需要在使用的时候传入strSQL查询语句
objCon.Execute strSQL
End Sub
Sub Update_Data(strSQL as String)
'示例strSQL = "UPDATE TableName SET Column_Name2= 'Value2' WHERE Column_Name1='Value1"
'需要在使用的时候传入strSQL查询语句
objCon.Execute strSQL
End Sub
Sub Read_Data(strSQL As String, shtName As String, objConn As ADODB.Connection)
'示例strSQL = "SELECT * FROM TableName"
Set objRecordSet = New ADODB.Recordset
objRecordSet.Open strSQL, objConn
'输出字段名称和查询内容
With ThisWorkbook.Sheets(shtName)
.UsedRange.ClearContents
.Range("A1").Select
For Each objField In objRecordSet.Fields
ActiveCell.Value = objField.Name
ActiveCell.Offset(0, 1).Select
Next
.Range("A2").CopyFromRecordset objRecordSet
.Range("A1").CurrentRegion.EntireColumn.AutoFit
End With
End Sub

复制代码

xmh850216 · 发表于 2019-8-16 12:33

进阶, 使用commit
在操作数据库时，不想实时读写，遇到错误的时候需要回滚引用这段代码时，需要自己根据实际情况修改SQL相关字段名称和语句

新增

Sub Main_Insert()
Dim objConn As ADODB.Connection
Dim i As Integer, total_row As Integer
Dim myPath As String
'放在共享盘上，方便多人操作，权限需要通过共享盘来控制
myPath = "\\ant\Database" & "\db.mdb"
With Sheets("新增")
total_row = .Cells(Rows.Count, 1).End(xlUp).Row
'Excel一大特征就是灵活，代价是对数据格式控制的不好，即便设置了数据有效性，也会被用户轻易覆盖，本段代码用来检查key值是否为空，可以增加检查其他字段
i = 2
Do While (i <= total_row)
If .Cells(i, 1).Value = Null Or Trim(.Cells(i, 1).Value) = "" Then
MsgBox ("第一列Tracking Number有空值，请检查后再上传！ --" & i & "行")
Exit Sub
End If
i = i + 1
Loop
Set objConn = Connect(myPath)
On Error GoTo CleanFail
objConn.BeginTrans
i = 2
Do While (i <= total_row)
Tracking_Number = .Cells(i, 1).Value
Depart_Date = .Cells(i, 2).Value
Scan_Date = .Cells(i, 3).Value
User_Name = .Cells(i, 4).Value
Report_ID = .Cells(i, 5).Value
Filling_Number = .Cells(i, 6).Value
Uploader = .Cells(i, 7).Value
strSQL = "Insert Into Expense (Tracking_Number,Depart_Date,Scan_Date,User_Name,Report_ID,Filling_Number,Uploader) " & _
"Values('" & Tracking_Number & "'," & _
IIf(Depart_Date = 0, "Null", "'" & Depart_Date & "'") & "," & _
IIf(Scan_Date = 0, "Null", "'" & Scan_Date & "'") & ",'" & _
User_Name & "','" & Report_ID & "','" & Filling_Number & "','" & Uploader & "')"
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = objConn
cmd.CommandType = adCmdText
cmd.CommandText = strSQL
cmd.Execute
i = i + 1
Loop
'循环全部完成后统一提交
objConn.CommitTrans
End With
CleanExit:
Call CloseConnection(objConn)
MsgBox "数据上传成功！", vbOKOnly, "成功"
Exit Sub
CleanFail:
objConn.RollbackTrans
MsgBox "上传数据有误，本次未成功上传." & Err.Description
Debug.Print Err.Number, Err.Description
Call CloseConnection(objConn)
Exit Sub
End Sub

复制代码

xmh850216 · 发表于 2019-8-16 12:33

删除

Sub Main_Delete()
Dim objConn As ADODB.Connection
Dim i As Integer, total_row As Integer
Dim myPath As String
myPath = "\\ant\Database" & "\db.mdb"
With Sheets("删除")
total_row = .Cells(Rows.Count, 1).End(xlUp).Row
'Excel一大特征就是灵活，代价是对数据格式控制的不好，即便设置了数据有效性，也会被用户轻易覆盖，本段代码用来检查key值是否为空，可以增加检查其他字段
i = 2
Do While (i <= total_row)
If .Cells(i, 1).Value = Null Or Trim(.Cells(i, 1).Value) = "" Then
MsgBox ("第一列Parcel Tracking Number有空值，请检查后再上传！ --" & i & "行")
Exit Sub
End If
i = i + 1
Loop
Set objConn = Connect(myPath)
On Error GoTo CleanFail
objConn.BeginTrans
i = 2
Do While (i < total_row + 1) '条件判定,运行到最后一行
strSQL = "DELETE FROM Expense WHERE Tracking_Number='" & .Cells(i, 1).Value & "'"
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = objConn
cmd.CommandType = adCmdText
cmd.CommandText = strSQL
cmd.Execute
i = i + 1
Loop
objConn.CommitTrans
End With
CleanExit:
Call CloseConnection(objConn)
MsgBox "数据删除成功！", vbOKOnly, "成功"
Exit Sub
CleanFail:
objConn.RollbackTrans
MsgBox "数据有误，本次未成功删除." & Err.Description
Debug.Print Err.Number, Err.Description
Call CloseConnection(objConn)
Exit Sub
End Sub

复制代码

xmh850216 · 发表于 2019-8-16 12:36

本帖最后由心电感应于 2019-8-16 13:57 编辑

更新

Sub Main_Update()
Dim objConn As ADODB.Connection
Dim myPath As String
Dim strSQL As String
Dim shtName As String
Dim i As Integer, total_row As Integer
myPath = "\\ant\Database" & "\db.mdb"
With ThisWorkbook.Sheets("更新")
total_row = .Cells(Rows.Count, 1).End(xlUp).Row
'Excel一大特征就是灵活，代价是对数据格式控制的不好，即便设置了数据有效性，也会被用户轻易覆盖，本段代码用来检查key值是否为空，可以增加检查其他字段
i = 2
Do While (i <= total_row)
If .Cells(i, 1).Value = Null Or Trim(.Cells(i, 1).Value) = "" Then
MsgBox ("第一列Parcel Tracking Number有空值，请检查后再上传！ --" & i & "行")
Exit Sub
End If
i = i + 1
Loop
Set objConn = Connect(myPath)
On Error GoTo CleanFail
objConn.BeginTrans
i = 2
Do While (i <= total_row)
Tracking_Number = .Cells(i, 1).Value
Depart_Date = .Cells(i, 2).Value
Scan_Date = .Cells(i, 3).Value
User_Name = .Cells(i, 4).Value
Report_ID = .Cells(i, 5).Value
Filling_Number = .Cells(i, 6).Value
Uploader = .Cells(i, 7).Value
strSQL = "UPDATE Expense SET Depart_Date=" & IIf(Depart_Date = 0, "Null", "'" & Depart_Date & "'") & "," & _
"Scan_Date=" & IIf(Scan_Date = 0, "Null", "'" & Scan_Date & "'") & "," & _
"User_Name='" & User_Name & "'," & _
"Report_ID='" & Report_ID & "'," & _
"Filling_Number='" & Filling_Number & "'," & _
"Uploader='" & Uploader & "' " & _
"where Tracking_Number ='" & Tracking_Number & "' "
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = objConn
cmd.CommandType = adCmdText
cmd.CommandText = strSQL
cmd.Execute
i = i + 1
Loop
objConn.CommitTrans
End With
CleanExit:
Call CloseConnection(objConn)
MsgBox "数据更新成功！", vbOKOnly, "成功"
Exit Sub
CleanFail:
objConn.RollbackTrans
MsgBox "更新有误！" & Err.Description
Debug.Print Err.Number, Err.Description
Call CloseConnection(objConn)
Exit Sub
End Sub

复制代码

查询
引用了基础模块里的Read_Data

Sub Main_Read()
Dim objConn As ADODB.Connection
Dim myPath As String
Dim strSQL As String
Dim shtName As String
myPath = "\\ant\Database" & "\db.mdb"
Set objConn = Connect(myPath)
strSQL = "Select * from Expense"
shtName = "查询"
Call Read_Data(strSQL, shtName, objConn)
Call CloseConnection(objConn)
End Sub

复制代码

opel-wong · 发表于 2019-8-16 16:06

搞个附件上来啊，

xmh850216 · 发表于 2019-8-16 17:27

opel-wong 发表于 2019-8-16 16:06
搞个附件上来啊，

授人以鱼不如授人以渔，附件等过两天再上传吧

wowo000 · 发表于 2019-8-18 07:38

xmh850216老师，没有附件呀。可否弄个上传？

用心修炼 · 发表于 2019-8-18 11:31

先mark一下，后面学习

xmh850216 · 发表于 2019-8-19 11:51

public.zip (66.54 KB, 下载次数: 330)

附件，新增的时候如果key和库里的数据重复，会设置成失败

twj007 · 发表于 2020-3-25 17:45

xmh850216 发表于 2019-8-19 11:51
附件，新增的时候如果key和库里的数据重复，会设置成失败

运行出错

		自动登录	找回密码
密码			免费注册

[分享] Excel VBA 对 Access增删改查代码分享

评分

评分