CODEWITHSUNDEEP
vbaexcelms-access
tortofe01
tortofe01

Reputation: 51

Transmit Data to Access from Excel and then Run Update Query

I have some code that I'm using that transmits some data from Excel to an Access database (this code is in an excel file). It works perfectly fine thus far. However, while I have the connection open in Excel to the Access database I want to know how I can run an update query that is inside the same access database immediately following the transmit of data from this code in excel (and without any warnings coming from access about running the update query). Can someone help?

Here's my code:

 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

Upvotes: 0

Views: 301

Answers (1)

Doug Coats
Doug Coats

Reputation: 7107

Here is a template i use for adodb connections for running execute sql commands. I do realize that this is a template for a sql server connection but you already have the connection part set up so, just take what you need from this :)

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

As far as suppressing the error message from access 

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

& when done

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

Upvotes: 1

Related Questions