Excel文件使用SQL操作Access

Eddy Xu 2019/8/16 excel vba sql access

前提：

本例使用的是Office 2016

添加ADO Lib引用

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

Excel-CRUD-Step1

勾选 Microsoft ActiveXData Object

Excel-CRUD-Step2

创建链接

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

1
2
3
4
5
6
7
8
9
10
11

关闭链接

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

1
2
3
4
5
6

增/删/改/查基础程序

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

进阶, 使用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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

删除

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

更新

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69

查询

引用了基础模块里的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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

Excel文件使用SQL操作Access

# 前提：

# 添加ADO Lib引用

# 创建链接

# 关闭链接

# 增/删/改/查 基础程序

# 进阶, 使用commit

# 新增

# 删除

# 更新

# 查询

前提：

添加ADO Lib引用

创建链接

关闭链接

增/删/改/查基础程序

进阶, 使用commit

新增

删除

更新

查询