VBA - Executing ADODB.CommandText - sql

I promised myself I would not post this because I have this delusional thought that I am too good of a programmer, yet here we are.
I have altered what I posted earlier last week trying to figure out how to write a VBA function that would write data from an Excel Range to an MS SQL Table. That worked.
Towards the end of the program, I do not know how to construct the final execution of the code; I have tried everything from using the Command.Text in the upper levels, setting it to a Recordset, then executing the recordset, but nothing will make the little VBA troll happy. Here is what I currently have written:
Sub Connection()
Dim Tbl As String
Dim InsertQuery As New ADODB.Command
InsertQuery.CommandType = adCmdText
Dim xlRow As Long, xlCol As Integer
Dim DBconnection As New ADODB.Connection
Dim ConnString As String
Dim rst As New ADODB.Recordset
Dim a As Integer, sFieldName As String
Dim db As DAO.Database
Dim CurrentDb As Database
Dim ConnectionStr
ConnectionStr = "Provider=sqloledb;Server="";Inital Catalog="";Integrated Security=SSPI;User ID="";Password="""
DBconnection.Open ConnectionStr
xlRow = 1 'only one row being used *as of now*, and that is the top row in the excel sheet
xlCol = 119 'First column of misc. data
While Cells(xlRow, xlCol) <> ""
If LH = True Then
Tbl = "Info.CaseBLH"
InsertQuery.CommandText = "INSERT INTO " & Tbl & " VALUES('"
ElseIf RH = True Then
Tbl = "Info.CaseBRH"
InsertQuery.CommandText = "INSERT INTO " & Tbl & " VALUES('"
Else
MsgBox ("No available sheets")
'Application.Quit
End If
NK21Data.TableDefs(Tbl).Fields.Count
For a = 1 To Fields.Count - 1
'For xlCol = 119 To 230 'columns DO1 to HV1
Fields.Item(a) = Replace(Cells(xlRow, xlCol), "'", "''") & "', '" 'Includes mitigation for apostrophes in the data
If Cells(xlRow, xlCol) = "" Then
rst.Fields.Item(a) = "NULL"
End If
xlCol = xlCol + 1
Next a
a = a + 1
Fields.Item(a) = (Format(Now(), "M/D/YYYY") & "')" & vbCrLf)
Wend
'On Error GoTo ErrorHandler
DBconnection.Execute (InsertQuery.CommandText)
DBconnection.Close
Set DBconnection = Nothing
ErrorHandler:
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
The error I get is:
Command text was not set for the command object.
This error occurs at:
DBconnection.Execute (InsertQuery.CommandText)
If I try using the following:
InsertQuery = DBconnection.Execute
I will get the following error:
Argument not optional
I've been at this for about (give or take) three days and I'm now having nightmares about it so if someone can help me figure out what to do for this I would greatly appreciate it.

I fixed up and cleaned the code from my earlier answer, tested it to work:
Here's the code:
Option Explicit
Sub DoItThen()
Dim i As Integer, sqlIns As String, sqlVals As String
Dim InsertQuery As New ADODB.Command
Dim firstRow As Long, firstCol As Integer, lastCol As Integer, currRow As Integer
Dim DBconnection As New ADODB.Connection
Dim ConnString As String
ConnString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=Example;Data Source=MYMACHINENAME"
DBconnection.Open ConnString
InsertQuery.ActiveConnection = DBconnection
InsertQuery.CommandType = adCmdText
''build the command text side by side, named columns and values with param placeholders
sqlIns = "INSERT INTO person("
sqlVals = " VALUES("
''i could work these out by scanning the sheet i suppose. hardcoded for now
firstRow = 2
firstCol = 3
lastCol = 5
''generate the SQL - its this that lets the column names come in any order in the sheet
For i = firstCol To lastCol
sqlIns = sqlIns & Cells(firstRow, i) & ","
sqlVals = sqlVals & "?,"
InsertQuery.Parameters.Append InsertQuery.CreateParameter("p" & i - firstCol, adVarChar, adParamInput, 255)
Next i
''chop off the extra trailing commas and form a syntax correct command
InsertQuery.CommandText = Left$(sqlIns, Len(sqlIns) - 1) & ")" & Left$(sqlVals, Len(sqlVals) - 1) & ")"
''iterate the data part of the sheet and execute the query repeatedlty
currRow = firstRow + 1
While Cells(currRow, firstCol) <> ""
For i = firstCol To lastCol
InsertQuery.Parameters("p" & i - firstCol).Value = Cells(currRow, i)
Next i
InsertQuery.Execute , , adExecuteNoRecords ''dont return a resultset
currRow = currRow + 1
Wend
DBconnection.Close
Set DBconnection = Nothing
ErrorHandler:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
It takes the first row as the names of the columns in the db table - any order is fine
It builds a command and populates the parameters
It repeatedly fills the values and executes the query, populating the table

OK; don't shoot me - I'm no VBA whizz but I'm saying you should strive to make your code more like this:
Sub DoItThen()
Dim a As Integer, sql as String
Dim InsertQuery As New ADODB.Command
Dim xlRow As Long, xlCol As Integer
Dim DBconnection As New ADODB.Connection
Dim ConnString As String
ConnString = "Provider=sqloledb;Server="";Inital Catalog="";Integrated Security=SSPI;User ID="";Password="""
DBconnection.Open ConnString
InsertQuery.ActiveConnection = conn
InsertQuery.CommandType = adCmdText
If LH = True Then
sql = "INSERT INTO Info.CaseBLH VALUES(#p1"
ElseIf RH = True Then
sql = "INSERT INTO Info.CaseBRH VALUES(#p1"
Else
MsgBox ("No available sheets")
'Application.Quit
End If
''does this do anything? I don't know
NK21Data.TableDefs(Tbl).Fields.Count
''let us add some placeholders to the command: we add count-2 because we already have one ? in the command
''ps; don't know where you got fields.count from
For a = 2 To Fields.Count - 1
sql = sql & ",#p" & a
Next a
''finish off our command
InsertQuery.CommandText = sql & ")"
''now we have a command like INSERT INTO tbl VALUES(#p1, #p2, #p3.."
''and setting the command text might pre-populate the parameters collection
''with the same number of parameters as are in the command, so let's clear it and
''add the parameters again ourselves so we can control the type
InsertQuery.Parameters.Clear
''create a load of parameters
For a = 1 To Fields.Count - 1
InsertQuery.Parameters.Append InsertQuery.CreateParameter("#p" & a, adVarChar, adParamInput, 255) 'adjust if you have strings longer than 255
Next a
''Now all the parameters are set etc, we just go through all the rows,
''and all the columns and set the values, then execute the command, then change the values and execute again
''--> set the command up once and repeatedly execute it
xlRow = 1 'only one row being used *as of now*, and that is the top row in the excel sheet
xlCol = 119 'First column of misc. data
While Cells(xlRow, xlCol) <> ""
For a = 1 To Fields.Count - 1
InsertQuery.Parameters("#p" & a).Value = Cells(xlRow, xlCol + a)
Next a
InsertQuery.Execute , , adExecuteNoRecords ''dont return a resultset
Wend
DBconnection.Close
Set DBconnection = Nothing
ErrorHandler:
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
You have 100 columns and 1000 rows to insert from an excel sheet:
You set up the command, INSERT INTO ... VALUES (... 100 #parameter placeholders...)
You clear the parameters collection (in case VBA has decided to 'help' by creating them) and add a load of parameters that represent your strings in your sheet
You then iterate the sheet, row by row, setting each column value on the row, into the relevant parameter and after you set all the columns (100 times), you execute the command then move to the next row, set the values again and execute again (1000 times)
I've got absolutely no way of testing this, sorry - it's my best guess but I fully expect it still has some error because I don't really know where you got Fields from. The answer with 8 votes from here was helpful: VBA, ADO.Connection and query parameters - I distinctly recall from when I was using VB6 about 20 years ago, that ADODB would try and prepopulate the parameters collection in certain circumstances, with its guesses at the parameter types; we routinely cleared it and added our own, but you might have some success proceeding with the default parameters it makes
The names of the parameters are not relevant; only the position. There's no requirement that #p1 from the query string matches the #p1 name given for the parameter - if the first parameter in the string were called #bob and you then cleared and added a parameter named #alice, whatever #alice's value was would be assigned to #bob because #bob is first in the query and #alice is first in the parameters collection. I used #pXXX as a parameter name for ease of reference in both cases

Here is my basic ADODB Execute template. This isn't meant to be an answer but more a helpful post. It should assist in showing you what you're doing incorrectly, which appears to be simple syntax issues as well as being really new to this (formatting and other pieces of code suggest that maybe you've gotten yourself "googled into a corner.").
Private Sub ADODBExample()
Dim vbSql As String, cnnstr as string
Dim cnn As ADODB.Connection
vbSql = "sql statement ;"
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
End Sub
More helpful tips -
Stop looping through cells, ranges and other worksheet/book objects. Learn to use arrays - itll make processing way better.
Simplicity is best. You appear to doing what I consider alot of unnecessary things, but then again I dont know all the requirements.

So I amended the code to the following:
Sub Connection()
Dim i As Integer, sqlIns As String, sqlVals As String
Dim InsertQuery As New ADODB.Command
Dim firstRow As Long, firstCol As Integer, lastCol As Integer, currRow As Integer
Dim DBconnection As New ADODB.Connection
Dim ConnString As String
Dim Tbl As String
ConnString = "Provider=sqloledb;Server=SERVER;Inital Catalog=DB;Integrated Security=SSPI;User ID=ID;Password=PW;"
DBconnection.Open ConnString
InsertQuery.ActiveConnection = DBconnection
InsertQuery.CommandType = adCmdText
If LH = True Then
Tbl = "Info.CaseBLH"
sqlIns = "INSERT INTO Info.CaseBLH("
ElseIf RH = True Then
Tbl = "Info.CaseBRH"
sqlIns = "INSERT INTO Info.CaseBRH("
Else
MsgBox ("No available sheets")
'Application.Quit
End If
''build the command text side by side, named columns and values with param placeholders
sqlVals = " VALUES("
''i could work these out by scanning the sheet i suppose. hardcoded for now
firstRow = 1
firstCol = 119
lastCol = 231
''generate the SQL - its this that lets the column names come in any order in the sheet
For i = firstCol To lastCol
sqlIns = sqlIns & Cells(firstRow, i) & ","
sqlVals = sqlVals & "?,"
InsertQuery.Parameters.Append InsertQuery.CreateParameter("p" & i - firstCol, adVarChar, adParamInput, 255)
Next i
''chop off the extra trailing commas and form a syntax correct command
InsertQuery.CommandText = Left$(sqlIns, Len(sqlIns) - 1) & ")" & Left$(sqlVals, Len(sqlVals) - 1) & ")"
''iterate the data part of the sheet and execute the query repeatedlty
currRow = firstRow ' - not needed as the data is automatically replaced with the code above
While Cells(currRow, firstCol) <> ""
For i = firstCol To lastCol - 1
InsertQuery.Parameters("p" & i - firstCol).Value = Cells(currRow, i)
Next i
InsertQuery.Execute , , adExecuteNoRecords ''dont return a resultset
Wend
DBconnection.Close
Set DBconnection = Nothing
ErrorHandler:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub
Right at the
InsertQuery.Execute , , adExecuteNoRecords
Line I'm getting a error telling me there is a syntax error around the ':' which doesn't make any sense to me. If I append my code to send the error to the error handler, every single row it cycles through throws me an error saying there is a syntax error around '-' or '/'. I think it has something to do with the parameter.value line.

Related

Getting ODBC - System Resources Exceeded (Rutime error 3035)

Need some assistance. I took Gord Thompson's code here How to increase performance for bulk INSERTs to ODBC linked tables in Access? and modified it to fit my case.
I am trying to copy the contents of a query called 'bulk_insert' (which is based on a local table in MS Access DB) into a SQL linked table called dbo_tblCVR_Matching_tmp. The query has no calculated fields or functions or nothing, just 102 columns of plain data. I'm currently testing with files in the range of 6K to 10K records.
The code executes and it copies many records over before I get the error in the title of this thread. I have looked around, but there is nothing that would help me with my particular issue. Not sure if I have to clear or refresh something. Here is the 2 routines I'm using:
'==============================================================
'Gord Thompson Stackoverflow: https://stackoverflow.com/questions/25863473/how-to-increase-performance-for-bulk-inserts-to-odbc-linked-tables-in-access
'==============================================================
Sub bulk_insert()
Dim cdb As DAO.Database
Dim rst As DAO.Recordset
Dim t0 As Single
Dim i As Long
Dim c As Long
Dim valueList As String
Dim separator As String
Dim separator2 As String
t0 = Timer
Set cdb = CurrentDb
Set rst = cdb.OpenRecordset("SELECT * FROM bulk_insert", dbOpenSnapshot)
i = 0
valueList = ""
separator = ""
Do Until rst.EOF
i = i + 1
valueList = valueList & separator & "("
separator2 = ""
For c = 0 To rst.Fields.Count - 1
valueList = valueList & separator2 & "'" & rst.Fields(c) & "'"
If c = 0 Then
separator2 = ","
End If
Next c
valueList = valueList & ")"
If i = 1 Then
separator = ","
End If
If i = 1000 Then
SendInsert valueList
i = 0
valueList = ""
separator = ""
End If
rst.MoveNext
Loop
If i > 0 Then
SendInsert valueList
End If
rst.Close
Set rst = Nothing
Set cdb = Nothing
Debug.Print "Elapsed time " & Format(Timer - t0, "0.0") & " seconds."
End Sub
'==============================================================
Sub SendInsert(valueList As String)
Dim cdb As DAO.Database
Dim qdf As DAO.QueryDef
Set cdb = CurrentDb
Set qdf = cdb.CreateQueryDef("")
qdf.Connect = cdb.TableDefs("dbo_tblCVR_Matching_tmp").Connect
qdf.ReturnsRecords = False
qdf.sql = "INSERT INTO dbo.tblCVR_Matching_tmp (" & _
"Associate_Id , Recd_Date, Price_Sheet_Eff_Date, VenAlpha, Mfg_Name, Mfg_Model_Num, Fei_Alt1_Code, Mfg_Product_Num, Base_Model_Num, Product_Description," & _
"Qty_Base_UOM , Price_Invoice_UOM, Mfr_Pub_Sugg_List_Price, Mfr_Net_Price, IMAP_Pricing, Min_Order_Qty, UPC_GTIN, Each_Weight, Each_Length, Each_Width," & _
"Each_Height, Inner_Pack_GTIN_Num, Inner_Pack_Qty, Inner_Pack_Weight, Inner_Pack_Length, Inner_Pack_Width, Inner_Pack_Height, Case_GTIN_Num, Case_Qty," & _
"Case_Weight, Case_Length, Case_Width, Case_Height, Pallet_GTIN_Num, Pallet_Qty, Pallet_Weight, Pallet_Length, Pallet_Width, Pallet_Height, Pub_Price_Sheet_Eff_Date," & _
"Price_Sheet_Name_Num, Obsolete_YN, Obsolete_Date, Obsolete_Stock_Avail_YN, Direct_Replacement, Substitution, Shelf_Life_YN, Shelf_Life_Time, Shelf_Life_UOM," & _
"Serial_Num_Req_YN, LeadLaw_Compliant_YN, LeadLaw_3rd_Party_Cert_YN, LeadLaw_NonPotable_YN, Compliant_Prod_Sub, Compliant_Prod_Plan_Ship_Date, Green, GPF, GPM," & _
"GPC, Freight_Class, Gasket_Material, Battery_YN, Battery_Type, Battery_Count, MSDS_YN, MSDS_Weblink, Hazmat_YN, UN_NA_Num, Proper_Shipping_Name," & _
"Hazard_Class_Num, Packing_Group, Chemical_Name, ORMD_YN, NFPA_Storage_Class, Kit_YN, Load_Factor, Product_Returnable_YN, Product_Discount_Category," & _
"UNSPSC_Code, Country_Origin, Region_Restrict_YN, Region_Restrict_Regulations, Region_Restrict_States, Prop65_Eligibile_YN, Prop65_Chemical_Birth_Defect," & _
"Prop65_Chemical_Cancer, Prop65_Chemical_Reproductive, Prop65_Warning, CEC_Applicable_YN, CEC_Listed_YN, CEC_Model_Num, CEC_InProcess_YN, CEC_Compliant_Sub," & _
"CEC_Compliant_Sub_Cross_YN, Product_Family_Name, Finish, Kitchen_Bathroom, Avail_Order_Date, FEI_Exclusive_YN, MISC1, MISC2, MISC3" & _
") Values " & valueList
'this is the line that is always highlighted when the error occurs
qdf.Execute dbFailOnError
Set qdf = Nothing
Set cdb = Nothing
End Sub
This is the final version of the code after testing it a million times, just in case someone runs into my same issue. Again thx to Albert Kallal for helping me out on this.
I added some comments in the code as well as additional information to get this thing working on one go.
In my case,
I took care of any duplicates before querying the records (i.e. I created an append query to copy the records to a local table with a primary key)
Created a pass through query 'p'
Used a function to help me escape chars such as the single quote char and deal with nulls and blanks
Integrated a dlookup function to prevent me from going crazy on hard coding the names of every column on my query. Also to allow filtering of empty columns to maximize the use of the chunk size
' =============================================================
' Credit to Albert Kallal Getting ODBC - System Resources Exceeded (Rutime error 3035)
' =============================================================
Sub bulk_insert()
Dim rstLocal As DAO.Recordset
Set rstLocal = CurrentDb.OpenRecordset("bi") 'bi is the name of the query I'm using to list of the records in the bulk
Dim sBASE As String ' base sql insert string
Dim sValues As String ' our values() list built up
Dim t As Single
t = Timer
Dim i As Long
Dim j As Long
Dim c As Long
Dim ChunkSize As Long ' # length size of "text" to send to server
Dim separator2 As String
Dim potentialHeader As String
Dim test
Dim filledArray() As Long
ChunkSize = 48000 'chunk size / or number of chars
'Try to programmatically create the insert, we will also remove anything that doesn't have values
With rstLocal
If Not rstLocal.EOF Then
sBASE = "INSERT INTO dbo.tblCVR_Matching_tmp (" 'this is where I added my SQL table
ReDim filledArray(0 To .Fields.Count - 1)
separator2 = ""
For c = 0 To .Fields.Count - 1 'using loop to get all the headers in my query
potentialHeader = .Fields(c).Name
test = DLookup(potentialHeader, "bi", potentialHeader & " is not null") 'using the dlookup function to isolate headers from my query that have values in its column
If test <> "" Then
filledArray(c) = 1
sBASE = sBASE & separator2 & potentialHeader
separator2 = ","
Else
filledArray(c) = 0
End If
Next c
sBASE = sBASE & ") VALUES "
End If
End With
Dim RowsInChunk As Long ' this will show rows that fit into a chunk
Dim RowCountOut As Long
sValues = ""
Do While rstLocal.EOF = False
RowCountOut = RowCountOut + 1
If sValues <> "" Then sValues = sValues & ","
RowsInChunk = RowsInChunk + 1
sValues = sValues & "("
separator2 = ""
With rstLocal
For c = 0 To .Fields.Count - 1
If filledArray(c) = 1 Then
sValues = sValues & separator2 & sql_escape(.Fields(c)) 'using sql_escape function for cells that have 'null' or single quotes... the function helps escape the characters to avoid getting errors on the insert
separator2 = ","
Else
'SKIP IF ALL NULLS
End If
Next c
End With
sValues = sValues & ")"
If (Len(sBASE) + Len(sValues)) >= ChunkSize Then
'send data to server
With CurrentDb.QueryDefs("p")
.sql = sBASE & sValues
.Execute
End With
Debug.Print "Rows in batch = " & RowsInChunk 'displays the number of rows per batch sent on each bulk insert statement
RowsInChunk = 0
sValues = ""
DoEvents
End If
rstLocal.MoveNext
Loop
' send out last batch (if any)
If sValues <> "" Then
With CurrentDb.QueryDefs("p") 'using pass through query here. I named mine 'p'
.sql = sBASE & sValues
.Execute
End With
sValues = ""
End If
rstLocal.Close
t = Timer - t
Debug.Print "done - time = " & t 'displays information on the immediate window as to the total duration of the sub
End Sub
====this is the sql_escape function========
' detects if a values is string or null and properly escapes it
Public Function sql_escape(val As Variant)
If LCase(val) = "null" Or val = "" Or IsNull(val) Then
sql_escape = "NULL"
Else
' also need to escape "'" for proper sql
val = Replace(val, "'", "''")
sql_escape = "'" & val & "'"
End If
End Function
In your loop, put in a test for the value length.
I would trigger the insert at about 4000 characters, maybe try 8000.
Also, you want to use a pass-though query for this, else it will be slow.
So, the code will be say like you have, but make sure the output format is in t-sql (sql server) format, and not JET/ACE sql format.
Note that sql server DOES have a short hand for inserts, and we WANT to use that fact since this reduces the overhead (the sql syntax) by a large amount (and looking at your code, you DO seem to be doing this).
So, the formart we want is this:
INSERT INTO tblBig (ID, FirstName, LastName, City)
VALUES (134, 'Albert', 'Kallal', 'Edmonton'),
VALUES (134, 'Albert', 'Kallal', 'Edmonton'),
VALUES (134, 'Albert', 'Kallal', 'Edmonton');
Note how we only need ONE insert command for many rows.
So, our code stub will look like this:
Sub TestAppendNeedForSpeed()
' I wanted to allow PK inserts
With CurrentDb.QueryDefs("qryPass1")
.SQL = "SET IDENTITY_INSERT TBLbIG1 ON;"
.Execute
End With
Dim rstLocal As dao.Recordset
Set rstLocal = CurrentDb.OpenRecordset("tblBig")
Dim sBASE As String ' base sql insert string
Dim sValues As String ' our values() list built up
Dim t As Single
t = Timer
Dim i As Long
Dim j As Long
Dim ChunkSize As Long ' # length size of "text" to send to server
ChunkSize = 4000 ' I don't think going higher will help
sBASE = "INSERT INTO tblBig1 (ID,FirstName,LastName,City) VALUES "
Dim RowsInChunk As Long ' this will show rows that fit into a chunk - only FYI
Dim RowCountOut As Long
sValues = ""
Do While rstLocal.EOF = False
RowCountOut = RowCountOut + 1
If sValues <> "" Then sValues = sValues & ","
RowsInChunk = RowsInChunk + 1
With rstLocal
sValues = sValues & "(" & !ID & "," & qu(!FirstName) & "," & qu(!LastName) & "," & qu(!City) & ")"
End With
If (Len(sBASE) + Len(sValues)) >= ChunkSize Then
' send data to server
With CurrentDb.QueryDefs("qryPass1")
.SQL = sBASE & sValues
.Execute
End With
Debug.Print "(" & RowCount & ") -- buffer out - " & RowsInChunk
RowsInChunk = 0
sValues = ""
DoEvents
End If
rstLocal.MoveNext
Loop
' send out last batch (if any)
If sValues <> "" Then
With CurrentDb.QueryDefs("qryPass1")
.SQL = sBASE & sValues
.Execute
End With
sValues = ""
End If
rstLocal.Close
t = Timer - t
Debug.Print "done - time = " & t
End Sub
So, the way we have this laid out, we can set/tweak/test/try the best chunk size.
You not even close and in the same ball part to insert 4000 rows at a time. Try about 4000 characters, maybe 8000. Some systems, I seen about 12000 char chunk size work best.
And as noted, use the above pass-though query idea - it will also run MUCH faster.
You can expect about 15x to 20x speed improvement with above. So, in place of say 120 minutes, you see about 6 minutes of time.
So, use the above template and approach. Of course the ONE row of values could be an external sub (or function) call, but the above approach will get you the best speed.

Use VBA to import data from SSMS joined table into an Excel file

I am trying to import some fields from two tables that need to be joined from SSMS. The importation process is through VBA. When importing from a singular table, my query ran fine but when I tried introducing a joined format, I received the error Run-time error -2147217900 (80040e14) Incorrect Syntax near 'dd' This piece of code is where the error gets thrown:
'The line item below is what gets highlighted and throws the error message
rsData.Open strQuery, objConn
Sub GetData_Using_VERSION_ID()
Dim strConnectionString As String, strQuery As String, strMessage As String
Dim objConn As ADODB.Connection
Dim rsData As New ADODB.Recordset
Dim varArrayReader As Variant
Dim tot_rows As Long
Dim intLBoundColumn As Long, intUBoundColumn As Long ' this variable is meant to hold the lower and upper indexes of the 1st dimension of the Array (columns)
Dim intLBoundRow As Long, intUBoundRow As Long ' this variable is meant to hold the lower and upper indexes of the 2nd dimension of the Array (rows)
Dim intLBoundColumn2 As Long, intUBoundColumn2 As Long ' this variable is meant to hold the lower and upper indexes of the 1st dimension of the Array (columns)
Dim intLBoundRow2 As Long, intUBoundRow2 As Long ' this variable is meant to hold the lower and upper indexes of the 2nd dimension of the Array (rows)
Dim intLBoundColumn3 As Long, intUBoundColumn3 As Long ' this variable is meant to hold the lower and upper indexes of the 1st dimension of the Array (columns)
Dim intLBoundRow3 As Long, intUBoundRow3 As Long ' this variable is meant to hold the lower and upper indexes of the 2nd dimension of the Array (rows)
Dim intLBoundColumn4 As Long, intUBoundColumn4 As Long ' this variable is meant to hold the lower and upper indexes of the 1st dimension of the Array (columns)
Dim intLBoundRow4 As Long, intUBoundRow4 As Long ' this variable is meant to hold the lower and upper indexes of the 2nd dimension of the Array (rows)
Dim i As Long, j As Long
Dim found As Integer
Dim VId As String
Dim ews As Excel.Worksheet
Dim sws As Excel.Worksheet
Dim lws As Excel.Worksheet
'Variable to determine if App version is found for ny_id lookup
found = 0
VId = Cells(1, 3)
Set ews = Worksheets("Employer_Data")
Set sws = Worksheets("Student_Data")
Set lws = Worksheets("Loan_Data")
'Determine if Ny_id has been found or not to set the initial total rows
'tot_rows is the starting point for the inserting of the headers and data beneath them
If Cells(2, 1) = "" Or Cells(1, 1) = "" Then
tot_rows = 3
Else
tot_rows = Range("A2").End(xlDown).Row + 3
End If
'See if valid app version id input for lookup
If VId = "" Or Not IsNumeric(VId) Then
Rows(tot_rows - 1 & ":" & Rows.Count).ClearContents
ews.Rows(tot_rows - 1 & ":" & Rows.Count).ClearContents
sws.Rows(tot_rows - 1 & ":" & Rows.Count).ClearContents
lws.Rows(tot_rows - 1 & ":" & Rows.Count).ClearContents
Cells(tot_rows - 1, 1).Value = "Bad Application_Version_ID Entered"
ews.Cells(tot_rows - 1, 1).Value = "No Application_Version_ID Entered"
sws.Cells(tot_rows - 1, 1).Value = "No Application_Version_ID Entered"
lws.Cells(tot_rows - 1, 1).Value = "No Application_Version_ID Entered"
Else
'Connection string for our Dev Database
strConnectionString = "Provider = SQLOLEDB;" _
& "Data Source=NAME REMOVED FOR DATA INTEGRITY;" _
& "Initial Catalog=NAME REMOVED FOR DATA INTEGRITY;" _
& "User ID=NAME REMOVED FOR DATA INTEGRITY;" _
& "Password=NAME REMOVED FOR DATA INTEGRITY;"
'***THIS CODE WORKS BY PULLING FIELDS FROM A SINGULAR TABLE SOURCE BUT I NEED TO PULL FIELDS FROM A JOINED TABLE
'Add/Update/Remove Fields Here
'NY_CALCULATION SQL Statement to pull data
' strQuery = ""
' strQuery = strQuery & "SELECT NY_ID, APPLICATION_VERSION_ID, grad_year, year, month, calc_year, marital_status, number_dependents, " _
' & "annual_gross_salary , qual_income, month_part_cont, monthly_payment_non_law, monthly_payment_law, month_lrap_benefit, spouse_annual_gross_salary, " _
' & "spouse_monthly_payment_ug , orig_principle_law, adjusted_orig_principle_law " _
' & "FROM [dbo].[NY_CALCULATION]" & " WHERE APPLICATION_VERSION_ID in (" & VId & ") order by application_version_id, month"
'*************************************************************
'THIS IS THE QUERY STRUCTURE THAT I NEED TO USE TO PULL THE NECESSARY FIELDS FROM SSMS INTO AN EXCEL FILE, HOWEVER AS MENTIONED I RECEIVE AN ERROR. I ASSUME THAT MAYBE I DIDN'T STRUCTURE THE QUERY PROPERLY?
strQuery = ""
strQuery = strQuery & "SELECT ah.NY_ID, ah.NEW_APPLICATION_ID, dd.GRAD_YEAR, dd.FIRST_NAME, dd.LAST_NAME, dd.MARITAL_STATUS, dd.NUMBER_DEPENDENTS, " _
& "dd.LRAP_PROGRAM, dd.CREATED_TIME " _
& "FROM [dbo].[NY_APPLICATION_HISTORY] ah" _
& "LEFT JOIN [dbo].[NY_DEMOGRAPHIC_DATA] dd" _
& "ON dd.APPLICATION_VERSION_ID = ah.NEW_APPLICATION_ID" _
& " WHERE APPLICATION_VERSION_ID in (" & VId & ")" _
& "ORDER BY ah.NEW_APPLICATION_ID"
'Execute SQL statement
Set objConn = New ADODB.Connection
objConn.Open strConnectionString
Set rsData = New ADODB.Recordset
'The line item below is what gets highlighted and throws the error message
rsData.Open strQuery, objConn
'Check to see if we were able to find data with select statement
If rsData.EOF Then
Cells(tot_rows - 1, 2).Value = "No Calculation Data found for that Application_Version_ID"
Else

How to Transfer VBA UserForm Data To Access Database?

I have created a user form in excel to save my records in a sheets like sheet1.
But after few days working with this UserForm, it is now goes slower, because of heavy data saving in sheet1.
Now I want to save all records to a database and want to keep clean my sheet1.
So I can work on my UserForm easily or without any delay. Also wants updates my record by calling it via serial numbers.
but I don't want to keep any record in my sheet1.
my little code is below: -
Sub cmdAdd_Click()
On Error GoTo ErrOccured
BlnVal = 0
If BlnVal = 0 Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim txtId, txtName, GenderValue, txtLocation, txtCNum, txtEAddr, txtRemarks
Dim iCnt As Integer
iCnt = fn_LastRow(Sheets("Data")) + 1
If frmData.obMale = True Then
GenderValue = "Male"
Else
GenderValue = "Female"
End If
With Sheets("Data")
.Cells(iCnt, 1) = iCnt - 1
.Cells(iCnt, 2) = frmData.txtName
.Cells(iCnt, 3) = GenderValue
.Cells(iCnt, 4) = frmData.txtLocation.Value
.Cells(iCnt, 5) = frmData.txtEAddr
.Cells(iCnt, 6) = frmData.txtCNum
.Cells(iCnt, 7) = frmData.txtRemarks
.Columns("A:G").Columns.AutoFit
.Range("A1:G1").Font.Bold = True
.Range("A1:G1").LineStyle = xlDash
End If
End With
Dim IdVal As Integer
IdVal = fn_LastRow(Sheets("Data"))
frmData.txtId = IdVal
ErrOccured:
'TurnOn screen updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I will always be grateful to you.
Then, please try the next way. I will try creating of the necessary DB, table and fields using Excel VBA, too:
Copy the next piece of code which will create an empty DB, on the path you want:
Sub CreateEmptyDB()
Dim strPath As String, objAccess As Object
strPath = "C:\Your path\testDB"
Set objAccess = CreateObject("Access.Application")
Call objAccess.NewCurrentDatabase(strPath)
objAccess.Quit
End Sub
Programatically create the necessary table with its fields (`Start Date' added only to see how this type of data is handled...):
Sub createTableFields()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim Catalog As Object, cn As ADODB.Connection
Dim dbPath As String, scn As String, strTable As String
dbPath = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
Set Catalog = CreateObject("ADOX.Catalog")
Set cn = New ADODB.Connection
With cn
.Open scn
.Execute "CREATE TABLE " & strTable & " ([Name] text(255) WITH " & _
"Compression, " & "[Gender] text(255) WITH Compression, " & _
"[Location] text(255) WITH Compression, " & _
"[Address] text(255) WITH Compression, " & _
"[Number] number, " & _
"[Remarks] text(255) WITH Compression, " & _
"[Start Date] datetime)"
End With
cn.Close
End Sub
Add records to the newly created DB/Table:
Sub FillDataInDB()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim AccessDB As String, strTable As String, sql As String
Dim con As ADODB.Connection, rs As ADODB.Recordset, lastNo As Long
AccessDB = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
Set con = CreateObject("ADODB.connection")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB
sql = "SELECT * FROM " & strTable
Set rs = CreateObject("ADODB.Recordset")
rs.CursorType = 1 'adOpenKeyset on early binding
rs.LockType = 3 'adLockOptimistic on early binding
rs.Open sql, con
If rs.RecordCount = 0 Then
lastNo = 0 'when no records in the table
Else
rs.MoveLast: lastNo = rs("Number") 'the last recorded value
End If
rs.AddNew
rs("Name") = "Test name" 'frmData.txtName
rs("Gender") = "Test gender" 'GenderValue
rs("Location") = "Test Location" 'frmData.txtLocation.Value
rs("Address") = "Test Address" 'frmData.txtEAddr
rs("Number") = IIf(lastNo = 0, 100, lastNo + 1) 'auto incrementing against the last value
'but starting from 100
'you can use frmData.txtCNum
rs("Remarks") = "Remarkable table..." 'frmData.txtRemarks
rs("Start Date") = Date
rs.Update
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing
End Sub
Run the first two pieces of code in consecutive order (only once) and then start playing with the third one...
You can read the newly created DB Table (returning in an Excel sheet) in this way:
Sub ADO_Connection_ReadTable()
Dim conn As New Connection, rec As New Recordset, sh As Worksheet
Dim AccessDB As String, connString, query As String, strTable As String
AccessDB = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
Set sh = ActiveSheet 'use here the sheet you want
connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB
conn.Open connString
query = "SELECT * from " & strTable & ";"
rec.Open query, conn
'return in the sheet
sh.cells.ClearContents
'getting data from the recordset if any and returning some in columns A:B:
If (rec.RecordCount <> 0) Then
Do While Not rec.EOF
With sh.Range("A" & sh.cells(Rows.count, 1).End(xlUp).row).Offset(1, 0)
.Value2 = rec.fields(0).Value
.Offset(0, 1).Value2 = rec.fields(3)
End With
rec.MoveNext
Loop
End If
rec.Close: conn.Close
End Sub
You can use a query to return specific data according to a specific table field. You can find plenty of examples on the internet.
I tried also showing how to handle an automate recording for the 'Number' field. Of course, if you are able to keep track of it in a different way, you can record it as you need/wont.
Please, test the above code(s) and send some feedback. You can use the DB path as a Private constant at the module level and much other ways to optimize the code. It is just a minimum workable solution only showing the way... :)

Connect to database and write data from range in sheet

can someone help me with this code please? I am new to vba
I need to upload data from sheet xx, and the entire column A until it hits the first blank value in this column. It shows me run time error, incorrect syntax near 'true' on line with sqlstr
Thank you
Sub Upload()
Dim conn As New ADODB.Connection
Dim i As Integer
Dim ExpID As String
i = 2
Do While ActiveSheet.Cells(i, 1) > 0
If ActiveSheet.Cells(i, 1).EntireRow.Hidden = False Then
ExpID = ActiveSheet.Cells(i, 1)
End If
conn.Open "Provider=SQLOLEDB;Data Source=xxx;Initial Catalog=xxx;Integrated Security=SSPI;"
sqlstr = "Insert into xxx.tblBillingInvoicesPrint (InvoiceID) values '" & ActiveSheet.Cells(i, 1).Select & "'"
conn.Execute sqlstr
i = i + 1
Loop
End Sub

Looking up Access database in Excel

I want to do something very simple: I have an Access database with one table mapping thousands of product IDs to product information fields. In an Excel worksheet, the user types in perhaps 100 product IDs in the first column. I need for the remaining columns to pull in information from the Access database for the corresponding IDs. Specifically:
if I use MS-Query, it seems to insist on the output being a table. I simply want the output to be inside a single cell. Preferably, a formula that involves a SQL-type query.
I don't want any of the values to be updated automatically, but rather want all the columns updated only on user demand (the user could either choose refresh through a menu, or a VBA-based refresh button on the sheet is fine as well).
I'm thinking this would be a straightforward use case, but it seems surprisingly hard to find a solution. Thank you in advance!
Working from Excel, you can use ADO to connect to a database. For Access and Excel 2007/2010, you might:
''Reference: Microsoft ActiveX Data Objects x.x Library
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
''Not the best way to refer to a workbook, but convenient for
''testing. it is probably best to refer to the workbook by name.
strFile = ActiveWorkbook.FullName
''Connection string for 2007/2010
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0 xml;HDR=Yes;"";"
cn.Open strCon
''In-line connection string for MS Access
scn = "[;DATABASE=Z:\Docs\Test.accdb]"
''SQL query string
sSQL = "SELECT a.Stuff, b.ID, b.AText FROM [Sheet5$] a " _
& "INNER JOIN " & scn & ".table1 b " _
& "ON a.Stuff = b.AText"
rs.Open sSQL, cn
''Write returned recordset to a worksheet
ActiveWorkbook.Sheets("Sheet7").Cells(1, 1).CopyFromRecordset rs
Another possibility returns a single field from MS Access. This example uses late binding, so you do not need a library reference.
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer, j As Integer
strFile = "z:\docs\test.accdb"
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''Select a field based on a numeric reference
strSQL = "SELECT AText " _
& "FROM Table1 a " _
& "WHERE ID = " & Sheets("Sheet7").[A1]
rs.Open strSQL, cn, 3, 3
Sheets("Sheet7").[B1] = rs!AText
OK, this may seem a bit lengthy - Create an Excel-table - in the first row (from column two) you have the Fieldnames Exactly as you have them in the access-table, in the first column you have the desired key-values (e.g. CustomerIDs).
When you run the macro it fills in what it finds...
Sub RefreshData()
Const fldNameCol = 2 'the column with the first fieldname in it'
Dim db, rst As Object
Set db = DBEngine.workspaces(0).OpenDatabase("C:\path\to\db\name.accdb")
Set rst = db.openrecordset("myDBTable", dbOpenDynaset)
Dim rng As Range
Dim showfields() As Integer
Dim i, aRow, aCol As Integer
ReDim showfields(100)
Set rng = Me.Cells
aRow = 1 'if you have the fieldnames in the first row'
aCol = fldNameCol
'***** remove both '' to speed things up'
'On Error GoTo ExitRefreshData'
'Application.ScreenUpdating = False'
'***** Get Fieldnames from Excel Sheet'
Do
For i = 0 To rst.fields.Count - 1
If rst.fields(i).Name = rng(aRow, aCol).Value Then
showfields(aCol) = i + 1
Exit For
End If
Next
aCol = aCol + 1
Loop Until IsEmpty(rng(aRow, aCol).Value)
ReDim Preserve showfields(aCol - 1)
'**** Get Data From Databasetable'
aRow = 2 'startin in the second row'
aCol = 1 'key values (ID) are in the first column of the excel sheet'
Do
rst.FindFirst "ID =" & CStr(rng(aRow, aCol).Value) 'Replace ID with the name of the key field'
If Not rst.NoMatch Then
For i = fldNameCol To UBound(showfields)
If showfields(i) > 0 Then
rng(aRow, i).Value = rst.fields(showfields(i) - 1).Value
End If
Next
End If
aRow = aRow + 1
Loop Until IsEmpty(rng(aRow, aCol).Value)
ExitRefreshData:
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
And if you dont want your fieldnames in the excel sheet replace the paragraph "Get Fieldnames From Excelsheet" with this:
fieldnames = Split("field1name", "", "", "field3name")
For j = 0 To UBound(fieldnames) - 1
For i = 0 To rst.fields.Count - 1
If rst.fields(i).Name = fieldnames(j) Then
showfields(j + fldNameCol) = i + 1
Exit For
End If
Next
Next
ReDim Preserve showfields(UBound(fieldnames) - 1 + fldNameCol)
and add this at the top
dim j as integer
dim fieldnames