Передать данные для доступа из Excel, а затем запустить запрос на обновление

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

Вот шаблон, который я использую для соединений adodb для запуска команд execute sql.Я понимаю, что это шаблон для подключения к серверу sql, но у вас уже настроена часть подключения, поэтому просто возьмите то, что вам нужно из этого:)

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