Question

我有一些我正在使用的代码，它将一些数据从Excel传输到Access数据库（此代码位于excel文件中）。到目前为止它完美无缺。但是，当我在Excel中打开连接到Access数据库时，我想知道如何在excel中从此代码传输数据之后立即运行位于同一访问数据库内的更新查询（并且没有任何警告来自有关运行更新查询的访问权限）。有人可以帮忙吗？

这是我的代码：

 Sub ADOFromExcelToAccess2()

 If MsgBox("This Button Will Submit all Data in the Table below for 
 previously submitted to Round 2 (Submit New through 
 New Plan Form)! Are you sure?", vbYesNo) = vbNo Then Exit Sub


' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=\\server3\Plan_Items_Compatible.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open "Plan_Items", cn, adOpenKeyset, adLockBatchOptimistic, adCmdTable
' all records in a table

On Error GoTo transerror

cn.BeginTrans
r = 14 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column I in the table (starting on row 14)
    With rs
        .AddNew ' create a new record
        ' add values to each field in the record

        .Fields("UserName") = Range("X" & r).Value
        .Fields("Name") = Range("A" & r).Value
        .Fields("PlanYear") = Range("B" & r).Value
        .Fields("Category") = Range("C" & r).Value
        .Fields("RIType") = Range("D" & r).Value
        .Fields("RIName") = Range("E" & r).Value
        .Fields("GNS") = Range("U" & r).Value
        .Fields("COGSPlan") = Range("V" & r).Value
        .Fields("KCImpDate") = Range("F" & r).Value
        .Fields("PHImpDate") = Range("I" & r).Value
        .Fields("TBImpDate") = Range("L" & r).Value
        .Fields("AWImpDate") = Range("O" & r).Value
        .Fields("KCProb") = Range("G" & r).Value
        .Fields("PHProb") = Range("J" & r).Value
        .Fields("TBProb") = Range("M" & r).Value
        .Fields("AWProb") = Range("P" & r).Value
        .Fields("KCAnnualized") = Range("H" & r).Value
        .Fields("PHAnnualized") = Range("K" & r).Value
        .Fields("TBAnnualized") = Range("N" & r).Value
        .Fields("AWAnnualized") = Range("Q" & r).Value
        .Fields("DescOfRMISavings") = Range("R" & r).Value
        .Fields("ExplOfPlannedSavingsCalc") = Range("S" & r).Value
        .Fields("ExplainImpDate") = Range("T" & r).Value
        .Fields("UnitsOfMeasure") = Range("Y" & r).Value
        .Fields("KC_CYRealized") = Range("AJ" & r).Value
        .Fields("PH_CYRealized") = Range("AK" & r).Value
        .Fields("TB_CYRealized") = Range("AL" & r).Value
        .Fields("AW_CYRealized") = Range("AM" & r).Value
        .Fields("KC_FollowingYearRealized") = Range("AN" & r).Value
        .Fields("PH_FollowingYearRealized") = Range("AO" & r).Value
        .Fields("TB_FollowingYearRealized") = Range("AP" & r).Value
        .Fields("AW_FollowingYearRealized") = Range("AQ" & r).Value
        .Fields("FOBBox") = Range("Z" & r).Value
        .Fields("IBFBox") = Range("AB" & r).Value
        .Fields("WasteReductionBox") = Range("AD" & r).Value
        .Fields("DMUBox") = Range("AA" & r).Value
        .Fields("OtherBox") = Range("AC" & r).Value
        .Fields("YieldImprovementBox") = Range("AE" & r).Value
        .Fields("AnyCheckBoxYes") = Range("AF" & r).Value
        .Fields("KCConcept") = Range("AR" & r).Value
        .Fields("PHConcept") = Range("AS" & r).Value
        .Fields("TBConcept") = Range("AT" & r).Value
        .Fields("AWConcept") = Range("AU" & r).Value
        .Fields("COGSPlanCheck") = Range("AV" & r).Value
        .Fields("CategoryCheck") = Range("AW" & r).Value
        .Fields("Round") = Range("W" & r).Value
        .Fields("UniqueKey") = Range("AG" & r).Value
        .Fields("UniqueKeyWithOriginalRound") = Range("AH" & r).Value
        .Fields("UniqueKeyWithNewRound") = Range("AI" & r).Value
        ' add more fields if necessary...

    End With
    r = r + 1 ' next row
Loop
rs.UpdateBatch 'injects full table from excel into access at the same time, eliminating possible errors with inserting certain rows over others
cn.CommitTrans 'makes sure that there were no errors before sending off all of the data
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

 'copy information to Submitting information tab (password protected for 
 accountability)

ActiveSheet.Unprotect "4casting4life"
Sheets("Submitted Information").Unprotect "4casting4life"
     Sheets("Resubmit Round 1 to 2 Form").Select
Range("A13:BZ200").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Submitted Information").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

 'copy information to Submitting information- Unlocked tab (not password protected data)
ActiveSheet.Unprotect "4casting4life"
Sheets("Submitted Information- Unlocked").Unprotect "4casting4life"
     Sheets("Resubmit Round 1 to 2 Form").Select
Range("A13:BZ200").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Submitted Information- Unlocked").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
 Sheets("Submitted Information").Protect "4casting4life"



    MsgBox ("Data was Submitted Successfully for Round 2! A copy of your submitted data is on tab Submitted Information.")


    Exit Sub

    transerror:
    cn.RollbackTrans
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    MsgBox ("Error Submitting: Required Fields are: Category/RI Type/RI 
    Name/All Explanation Fields/Imp Dates by Concept/Probability by 
    Concept/Annualized Savings figures"), , "Data Input Error"
    MsgBox ("Data Was Not Submitted"), , "Data Input Error"



    End Sub

Answer 1

这是我用于运行execute sql命令的adodb连接的模板。我确实知道这是一个sql server连接的模板，但你已经设置了连接部分，只需从中获取所需内容：）

Private Sub sqlupdate()

    Dim rng As Range, rcell As Range
    Dim vbSql As String, chkNum As String, var As String
    Dim cnn As ADODB.Connection

    Set rng = ThisWorkbook.Sheets("Sheet2").Range("F2:F754")
    For Each rcell In rng.Cells
        var2 = rcell.Value
        var = rcell.Offset(0, 5).Value
        vbSql = "UPDATE tbl SET column='" & var & "' WHERE othercol='" & var2 & "';"
        Set cnn = New Connection
        cnnstr = "Provider=SQLOLEDB;Data Source=SERVERNAME;Initial Catalog=DBNAME;User ID=USERID;Password=PASSWORD; Trusted_Connection=No"
        cnn.Open cnnstr
        cnn.Execute vbSql
        cnn.Close
        Set cnn = Nothing
    Next rcell
End Sub

至于禁止访问错误消息

 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 Application.Calculation = xlCalculationManual

＆安培;完成后

 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 Application.Calculation = xlCalculationAutomatic

将数据传输到Excel，然后运行更新查询

1 个答案: