【VBA研究】如何将Excel工作表的内容更新到数据库

iamlaosong文

利用Excel维护数据库，自然就需要完成工作表内容和数据库表内容的互动。将数据库表的内容读到工作表中，这儿就不说了，本文主要是要说一下如何将工作表中修改后的内容更新到数据库表中。

比较快速的方法是采用记录集更新方法，这种方法比较快，也很方便。经测试，对access数据库是没有问题的，微软的SQL Server没测过，不过是一家产品，估计没问题，代码如下：

Sub SaveData_rst()
    'On Error GoTo ErrMsg:
    
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim sqls, mytable As String
    Dim i, j, n As Integer
     
    '建立连接,当前文件的路径可以用ThisWorkbook.Path
    Set cnn = New ADODB.Connection
    cnn.Open "Provider =Microsoft.ACE.OLEDB.12.0; Data Source = " & ThisWorkbook.Path & "\支付宝.accdb"
    mytable = "账号明细"
    n = Range("a1").End(xlDown).Row  '当前工作表有效行数
    '使用SQL语句操作数据库
    For i = 2 To n
        sqls = "select * from " & mytable & " where khzh='" & Cells(i, 1).Value & "'"
        Set rst = New ADODB.Recordset
        '用记录集对象执行SQL语句
        rst.Open sqls, cnn, adOpenKeyset, adLockOptimistic
        If rst.RecordCount = 0 Then rst.AddNew   '找不到，增加一条空记录
        For j = 1 To rst.Fields.Count
            rst.Fields(j - 1) = Cells(i, j).Value
        Next j
        rst.Update
    Next i
     
    rst.Close         ' 关闭记录集
    Set rst = Nothing ' 释放对象
    cnn.Close         ' 关闭连接
    Set cnn = Nothing ' 释放对象
     
    MsgBox "操作成功！"
    
End Sub

现在的问题是我用的不是access而是Oracle，上面的方法不能使用，连接Oracle数据库后，参数adOpenKeyset, adLockOptimistic是空值，用此参数会报错，即使用实值1、3（那两个参数的实际值）替换不报错，可以更新记录集依然不行，提示VBA不支持记录集动态更新。

既然此路不通，只好采取原始的办法，用SQL语句直接完成，实际应用的代码如下：

'将工作表数据保存到数据库
Sub SaveData(opName As String)
    Dim row1, k, KeyNum, FieldNo, MaxRow, UpdateNo, InsertNo As Integer
    Dim stName, tbName, KeyField, AllFields As String
    Dim MyRecord(50)
    
    On Error GoTo ErrMsg:
    If opName = "ZHMX" Then
        stName = "账号明细"
        tbName = "EMSAPP_ZFB_ZHMX"
        KeyNum = 1                  '关键字列号
        KeyField = "khzh"
        AllFields = "(khzh,dwmc,bmmc,khmc,mark)"
        FieldNo = 5
    Else
        Exit Sub
    End If
    
    OraOpen = OracleOpen() '成功执行后，数据库即被打开
    
    If OraOpen Then
        UpdateNo = 0
        InsertNo = 0
        With Sheets(stName)
            MaxRow = .[A65536].End(xlUp).Row
            '开始保存
            For row1 = 2 To MaxRow
                For k = 1 To FieldNo
                    MyRecord(k) = .Cells(row1, k)
                Next k
                sqls = "select count(*) from " & tbName & " where " & KeyField & " = '" & MyRecord(KeyNum) & "'"
                Set rst = cnn.Execute(sqls)
                Recno = rst(0)
                If Recno > 0 Then
                    sqls = "update " & tbName & " set " & AllFields & " = (select '"
                    For k = 1 To FieldNo - 1
                        sqls = sqls & MyRecord(k) & "','"
                    Next k
                    sqls = sqls & MyRecord(k) & "' from dual) where " & KeyField & " = '" & MyRecord(KeyNum) & "'"
                    UpdateNo = UpdateNo + 1
                    .Cells(row1, FieldNo + 1) = "更新OK"
                Else
                    '插入数据
                    sqls = "insert into " & tbName & AllFields & " values ('"
                    For k = 1 To FieldNo - 1
                        sqls = sqls & MyRecord(k) & "','"
                    Next k
                    sqls = sqls & MyRecord(k) & "') "
                    InsertNo = InsertNo + 1
                    .Cells(row1, FieldNo + 1) = "新增OK"
                End If
                Set rst = cnn.Execute(sqls)
            Next row1
        End With
    End If
    '保存日志msg
    Msg = "成功保存至数据库，其中更新：" & UpdateNo & "，新增：" & InsertNo
    
    Prog_Log (opName)     '日志
    OracleClose           '关闭连接
    Msg = MsgBox(Msg, vbOKOnly, "iamlaosong")
    Exit Sub
ErrMsg:
    MsgBox sqls, vbCritical, "操作失败 ，请检查！"

End Sub

增加一个参数opName的目的是让这个过程可以保存多个表。生成更新的SQL语句采用的格式是“update set (字段1，字段2...) =(select ‘值1’，'值2'... from dual) where 条件”这种格式，主要是方便写代码。所有的值都用单引号括起来是没有问题的，即使是数值也不影响，不过日期型是不行的，需要另外处理。

Oracle连接开关函数和过程代码如下：

'连接数据库
Function OracleOpen() As Boolean
    On Error GoTo ErrMsg:
    
    Set cnn = CreateObject("ADODB.Connection")
    Set rst = CreateObject("ADODB.Recordset")

    cnnstr = "Provider=msdaora;Data Source=dl580;User Id=emssxjk;Password=emssxjk;"
    cnn.Open cnnstr
    OracleOpen = True '成功执行后，数据库即被打开
    Exit Function
ErrMsg:
    OracleOpen = False
    
End Function

'关闭连接
Public Sub OracleClose()
    If rst.State = adStateOpen Then rst.Close
    Set rst = Nothing
    If cnn.State = adStateOpen Then cnn.Close
    Set cnn = Nothing
End Sub

最后，把读取数据到工作表中的过程列一下：

Public Sub GetData(opName As String)
    '根据工作表中的查询语句读取数据
    On Error GoTo ErrMsg:
    
    Dim stName, sqls As String
    Dim MaxRow As Integer
    Dim OraOpen As Boolean
    
    If opName = "ZHMX" Then
        stName = "账号明细"
        sqls = "select khzh,dwmc,bmmc,khmc,mark from EMSAPP_ZFB_ZHMX"
        sqls = sqls & " order by dwmc,bmmc,khzh"
    ElseIf opName = "JYMX" Then
        stName = "交易明细"
        sqls = "select a.jyrq,a.ywlsh,a.khzh,a.srje,a.mark,b.dwmc,b.bmmc,b.khmc from EMSAPP_ZFB_JYMX a, EMSAPP_ZFB_ZHMX b"
        sqls = sqls & " where a.jyrq between to_date('" & Sheets(stName).Range("M3") & "','yyyy-mm-dd') and to_date('"
        sqls = sqls & Sheets(stName).Range("N3") & "','yyyy-mm-dd') and a.khzh=b.khzh(+) order by dwmc,bmmc,khzh"
    Else
        Exit Sub
    End If
    
    OraOpen = OracleOpen() '成功执行后，数据库即被打开
    
    If OraOpen Then
        Set rst = cnn.Execute(sqls)
        sqls = "CopyFromRecordset"
        MaxRow = Sheets(stName).UsedRange.Rows.Count
        If MaxRow > 1 Then Sheets(stName).Range("A2:L" & MaxRow).ClearContents
        Sheets(stName).Range("A2").CopyFromRecordset rst
        
        OracleClose
        Exit Sub
    End If
ErrMsg:
    MsgBox Err.Description, vbCritical, "操作失败 ，请检查！"
    MsgBox sqls, vbCritical, "错误语句"

End Sub