I am working with vba, and I am using an excel sheet to find prices using SQL code within vba. Below is an example of how it is done:
Sub connection()
Set cn = New ADODB.connection
Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
.Open
End With
End Sub
Function getAddres(ByVal sTableName As String) As String
With Range(sTableName & "[#All]")
getAddres = "[" & .Parent.Name & "$" & .Address(False, False) & "]"
End With
End Function
Function Get_Coeff_1_crit(couv As String, tabelle As String, edit As String, crit1 As String) As Variant
Dim NomFeuille As String, texte_SQL As String
Dim rst As ADODB.Recordset
Dim strRangeAddress As String
Call connection
strRangeAddress = getAddres(edit)
texte_SQL = "SELECT [Coeff] FROM " & strRangeAddress & " WHERE ([Tabelle]=" & Chr(34) & tabelle & Chr(34) & _
" ) AND (( [Booléen_1] = " & crit1 & " ) OR ( [Fixe_1] = " & crit1 & " ) OR (" & crit1 & " BETWEEN [Min_1] AND [Max_1] ))"
Set rst = New ADODB.Recordset
Set rst = cn.Execute(texte_SQL)
On Error Resume Next
Get_Coeff_1_crit = 0
Get_Coeff_1_crit = rst.Fields(0).Value 'ws.Range("N7").CopyFromRecordset Rst
End Function
So I have an input of variables and this function looks for the table and correct variable combination.
My issue is that with many functions each establishing a separate connection with the excel sheet, it takes an insane amount of time to process a lot of prices.
I was wondering if anyone knows of a better way, I am rather new at vba, so I was wondering if we can store dataframes within the process like in python or is there a different way to not establish connections each time.
Thanks.
if you're looping over Get_Coeff_1_crit repeatedly then I can see why it's bogging down while it's reestablishing that connection each pass.
You'd want to do something like this inside the function,
If Not cn is Nothing then 'verify the object is instantiated
If cn.State = adStateClosed then 'State property tells if it's open
Call Connection
End If
End If
'further details on that property - https://www.w3schools.com/asp/prop_comm_state.asp
I am trying to open an Excel sheet using ADODB connection, but I am getting the following error when I try to execute the query although the name of the worksheet is correct:
Error number: 3704
Error Description:Operation is not allowed when the object is closed
I have gone through most of the answers provided online and I still can find my answer as I already have what was missing in the answers I read.
Here is my code:
Dim objConn
Set objConn = Server.CreateObject("ADODB.Connection")
Dim ext : ext = GetFileExt(filename)
If ext = "xlsx" Then
With objConn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = _
"Data Source=" & Server.MapPath("../import/" & filename) & ";" & _
"Extended Properties=Excel 12.0;"
.CursorLocation = adUseClient
.Open
End With
End If
Dim sql
sql = "SELECT * FROM [" & worksheet & "$]"
Dim objRs
Set objRs = objConn.Execute(sql)
response.write "err.number: " & Err.Number '3704
response.write "err.Description: " & Err.Description 'Operation is not allowed when the object is closed
I am working on a VBA macro which connects to my database on SQL Server and run some queries and save the results on CSV files... it works fine just when the queries returns data but i have days where the query doesn't return any results, just an empty table. I made a temporary solution based on checking the date and according it the macro runs that query or no... I want to make it other way now in my code so that i don't need to change the date everytime manually...
I tried these solutions :
If (objMyRecordset.EOF = False) Or (objMyRecordset.BOF = False) Then
Also this
If objMyRecordset.RecordCount <> 0 Then
but the problem is my Recordset is empty because the query doesn't return any rows so it shows me error in objMyRecordset.Open
I want to add a line of code like this for example :
'// Pseudo Code
If (the query doesn't return result) Then
( just the headers will be save on my file )
Else
(do the rest of my code)
End If
Here is my code. Any suggestions please ? Thank you very much.
Sub Load_after_cutoff_queryCSV()
Dim objMyConn As ADODB.Connection
Dim objMyCmd As ADODB.Command
Dim objMyRecordset As ADODB.Recordset
Dim fields As String
Dim i As Integer
Set objMyConn = New ADODB.Connection
Set objMyCmd = New ADODB.Command
Set objMyRecordset = New ADODB.Recordset
'Open Connection
objMyConn.ConnectionString = "Provider=SQLOLEDB;Data Source=*****;User ID=*****;Password=*****;"
objMyConn.Open
'Set and Excecute SQL Command
Set objMyCmd.ActiveConnection = objMyConn
objMyCmd.CommandText = "SELECT * FROM [vw_X86_LOAD_AFTER_CUTOFF_REPORT_GAMMA]"
objMyCmd.CommandType = adCmdText
'Open Recordset
Set objMyRecordset.Source = objMyCmd
objMyRecordset.Open
Workbooks.Open Filename:="C:\Reports\load_after_cutoff_postGamma.csv"
Workbooks("load_after_cutoff_postGamma.csv").Sheets("load_after_cutoff_postGamma").Activate
ActiveSheet.Range("A2").CopyFromRecordset objMyRecordset
For i = 0 To objMyRecordset.fields.Count - 1
Worksheets("load_after_cutoff_postGamma").Cells(1, i + 1) = objMyRecordset.fields(i).name
Next i
Workbooks("load_after_cutoff_postGamma.csv").Sheets("load_after_cutoff_postGamma").Cells.EntireColumn.AutoFit
Workbooks("load_after_cutoff_postGamma.csv").Close SaveChanges:=True
MsgBox "Your file has been saved as load_after_cutoff_postGamma.csv"
If you experience problems connecting to your server then this is due to any of the following:
an incorrect connection string
incorrect credentials
the server is not reachable (for example: network cable disconnected)
the server is not up and running
Sending a query to a server which results in an empty recordset is not a reason for an ADODB.Connection to fail.
Here is a little bit of code for you to try and debug the connection in a first step and then the query in a second step:
Option Explicit
Public Sub tmpSO()
Dim strSQL As String
Dim strServer As String
Dim strDatabase As String
Dim OutMail As Outlook.MailItem
Dim rstResult As ADODB.Recordset
Dim conServer As ADODB.Connection
Dim OutApp As Outlook.Application
strServer = "."
strDatabase = "master"
Set conServer = New ADODB.Connection
conServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
& "DATA SOURCE=" & strServer & ";" _
& "INITIAL CATALOG=" & strDatabase & ";" _
& "User ID='UserNameWrappedInSingleQuotes'; " _
& "Password='PasswordWrappedInSingleQuotes'; "
On Error GoTo SQL_ConnectionError
conServer.Open
On Error GoTo 0
strSQL = "set nocount on; "
strSQL = strSQL & "select * "
strSQL = strSQL & "from sys.tables as t "
strSQL = strSQL & "where t.name = ''; "
Set rstResult = New ADODB.Recordset
rstResult.ActiveConnection = conServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0
If Not rstResult.EOF And Not rstResult.BOF Then
ThisWorkbook.Worksheets(1).Range("A1").CopyFromRecordset rstResult
' While Not rstResult.EOF And Not rstResult.BOF
' 'do something
' rstResult.MoveNext
' Wend
Else
'https://msdn.microsoft.com/en-us/library/windows/desktop/ms675546(v=vs.85).aspx
Select Case conServer.State
'adStateClosed
Case 0
MsgBox "The connection to the server is closed."
'adStateOpen
Case 1
MsgBox "The connection is open but the query did not return any data."
'adStateConnecting
Case 2
MsgBox "Connecting..."
'adStateExecuting
Case 4
MsgBox "Executing..."
'adStateFetching
Case 8
MsgBox "Fetching..."
Case Else
MsgBox conServer.State
End Select
End If
Set rstResult = Nothing
Exit Sub
SQL_ConnectionError:
MsgBox "Couldn't connect to the server. Please make sure that you have a working connection to the server."
Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = "Problems connecting to database '" & strDatabase & "' hosted on the server '" & strServer & "'"
.HTMLBody = "<span style=""font-size:10px"">---Automatically generated Error-Email---" & _
"</span><br><br>Error report from the file '" & _
"<span style=""color:blue"">" & ThisWorkbook.Name & _
"</span>' located and saved on '<span style=""color:blue"">" & _
ThisWorkbook.Path & "</span>'.<br>" & _
"Excel is not able to establish a connection to the server. Technical data to follow." & "<br><br>" & _
"Computer Name: <span style=""color:green;"">" & Environ("COMPUTERNAME") & "</span><br>" & _
"Logged in as: <span style=""color:green;"">" & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "</span><br>" & _
"Domain Server: <span style=""color:green;"">" & Environ("LOGONSERVER") & "</span><br>" & _
"User DNS Domain: <span style=""color:green;"">" & Environ("USERDNSDOMAIN") & "</span><br>" & _
"Operating System: <span style=""color:green;"">" & Environ("OS") & "</span><br>" & _
"Excel Version: <span style=""color:green;"">" & Application.Version & "</span><br>" & _
"<br><span style=""font-size:10px""><br>" & _
"<br><br>---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
SQL_StatementError:
MsgBox "There seems to be a problem with the SQL Syntax in the programming."
Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = "Problems with the SQL Syntax in file '" & ThisWorkbook.Name & "'."
.HTMLBody = "<span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---" & _
"</span><br><br>" & _
"Error report from the file '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Name & _
"</span>" & _
"' located and saved on '" & _
"<span style=""color:blue"">" & _
ActiveWorkbook.Path & _
"</span>" & _
"'.<br>" & _
"It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
"SQL-Code causing the problems:" & _
"<br><br><span style=""color:green;"">" & _
strSQL & _
"</span><br><br><span style=""font-size:10px"">" & _
"---Automatically generated Error-Email---"
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
End Sub
Note, that the above code clearly distinguishes between (first) connecting to the server and then (afterwards) issuing a query to the server to retrieve some data. Both steps are separated and there is a different error handler for either case.
Furthermore, the above sample code also results in an empty recordset being returned. But the code is able to handle that incident with yet another error handler.
If the connection fails or if the SQL syntax being sent to the server contains error(s) then the above code will automatically generate an error email (using Outlook) with some details for you to check the connection and the SQL syntax.
you should go with your .EOF solution. Here is an example of mine, which I use regularly.
Sub AnySub()
''recordsets
Dim rec as ADODB.Recordset
''build your query here
sSql = "SELECT * FROM mytable where 1=0" ''just to have no results
''Fire query
Set rec = GetRecordset(sSql, mycnxnstring)
''and then loop throug your results, if there are any
While rec.EOF = False
''do something with rec()
rec.MoveNext
Wend
End sub
Here the Function GetRecordset() is given by:
Function GetRecordset(strQuery As String, connstring As String) As Recordset
Dim DB As ADODB.Connection
Dim rs As ADODB.Recordset
Set DB = New ADODB.Connection
With DB
.CommandTimeout = 300
.ConnectionString = connstring
.Open
End With
Set GetRecordset = DB.Execute(strQuery)
End Function
Hope this helps.
I want to connect to a MS SQL Server database using an Outlook macro. But I don't know if the code is wrong or I need to add a library/driver or what happens here but it doesn't work.
Private Sub Application_Startup()
On Error GoTo ExitHere
'adodb connection to other database
stg_cn.Open "Provider = SQLOLEDB;" & _
"Data Source = 192.168.100.100;" & _
"Initial Catalog = hugeDB;" & _
"Integrated Security=SSPI;" & _
"User ID = oneuser;" & _
"Password = onepassword;"
sQuery = "SELECT * FROM documents where location = 'IE'"
'set reference to query
Set cmd = New ADODB.Command
cmd.ActiveConnection = stg_cn
cmd.CommandType = adCmdText
cmd.CommandText = sQuery
Set rs = cmd.Execute
Do While Not rs.EOF
For i = 0 To rs.Fields.count - 1
MsgBox (i + 1)
Next
rs.MoveNext
Loop
ExitHere:
If Not stg_cn Is Nothing Then stg_cn.Close
Set rs = Nothing
Set stg_cn = Nothing
Exit Sub
End Sub
On eye-test I am not able to figure out whats wrong, I think it has to do something with the way you are doing the ADO operations.
But I am just putting up the last macro I wrote to connect to SQL-Server from Macro. Hope it helps.
Private Sub Workbook_Open()
On Error GoTo ErrorHandler
'**************************************Initialize Variables**************************************
sServer = "<SQL SERVER Server>"
sDBName = "<SQL SERVER DB>"
'**************************************Open Connection**************************************
'adodb connection to other database
stg_cn.Open "Provider=SQLOLEDB;Data Source=" & sServer & _
";Initial Catalog=" & sDBName & _
";Integrated Security=SSPI;"
sQuery = "SELECT * " & _
"FROM Table "
'set reference to query
Set cmd = New ADODB.Command
cmd.ActiveConnection = stg_cn
cmd.CommandType = adCmdText
cmd.CommandText = sQuery
Set rs = cmd.Execute
Do While Not rs.EOF
For i = 0 To rs.Fields.Count - 1
<PERFORM OPERATIONS>
Next
rs.MoveNext
Loop
ExitHere:
If Not stg_cn Is Nothing Then stg_cn.Close
Set rs = Nothing
Set stg_cn = Nothing
Exit Sub
End Sub
The connection string #CodePhobia has provided should work for you.
The below just includes User ID and Password functionality, as your original question showed trying to connect using this.
Dim rsConn as ADODB.Connection
Set rsConn = New ADODB.Connection
With rsConn
.ConnectionString = "Provider = sqloledb;" & _
"Data Source = myServerName;" & _
"Initial Catalog = myCatalog;" & _
"Integrated Security=SSPI;" & _
"User ID = myUserID;" & _
"Password = myPassword;"
.Open
End With
You can use this website to find connection strings in the future. It should cover all possible connections you wish to establish.
I am trying to update a table in Access from the values in excel, however every time i run the code it creates new rows instead of updating the already existing ones, any ideas why? I am new to ADO, so any advised is well appreciated
Private Sub SelectMaster()
Dim db As New ADODB.Connection
Dim connectionstring As String
Dim rs1 As Recordset
Dim ws As Worksheet
Set ws = ActiveSheet
connectionstring = "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=C:\Users\Giannis\Desktop\Test.mdb;"
db.Open connectionstring
Set rs1 = New ADODB.Recordset
rs1.Open "Men", db, adOpenKeyset, adLockOptimistic, adCmdTable
r = 6
Do While Len(Range("L" & r).Formula) > 0
With rs1
.AddNew
.Fields("Eva").Value = ws.Range("L" & r).Value
.Update
End With
r = r + 1
Loop
rs1.Close
'close database
db.Close
'Clean up
Set rs1 = Nothing
Set rs2 = Nothing
Set db = Nothing
End Sub
Here are some notes.
An example of updating row by row
''Either add a reference to:
''Microsoft ActiveX Data Objects x.x Library
''and use:
''Dim rs As New ADODB.Recordset
''Dim cn As New ADODB.Connection
''(this will also allow you to use intellisense)
''or use late binding, where you do not need
''to add a reference:
Dim rs As Object
Dim cn As Object
Dim sSQL As String
Dim scn As String
Dim c As Object
scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\docs\dbto.mdb"
''If you have added a reference and used New
''as shown above, you do not need these
''two lines
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open scn
sSQL = "SELECT ID, SName, Results FROM [Test]"
''Different cursors support different
''operations, with late binding
''you must use the value, with a reference
''you can use built-in constants,
''in this case, adOpenDynamic, adLockOptimistic
''see: http://www.w3schools.com/ADO/met_rs_open.asp
rs.Open sSQL, cn, 2, 3
For Each c In Range("A1:A4")
If Not IsEmpty(c) And IsNumeric(c.Value) Then
''Check for numeric, a text value would
''cause an error with this syntax.
''For text, use: "ID='" & Replace(c.Value,"'","''") & "'"
rs.MoveFirst
rs.Find "ID=" & c.Value
If Not rs.EOF Then
''Found
rs!Results = c.Offset(0, 2).Value
rs.Update
End If
End If
Next
An easier option: update all rows
scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\docs\dbto.mdb"
Set cn = CreateObject("ADODB.Connection")
cn.Open scn
sSQL = "UPDATE [Test] a " _
& "INNER JOIN " _
& "[Excel 8.0;HDR=YES;IMEX=2;DATABASE=C:\Docs\WB.xls].[Sheet1$] b " _
& "ON a.ID=b.ID " _
& "SET a.Results=b.Results"
cn.Execute sSQL, RecsAffected
Debug.Print RecsAffected
Your call to .AddNew is creating new rows.
Fionnuala
Many Thanks for the 'Easier Option' to update all rows.
Just to share that in my case (Office 2007 with Excel file in .xlsm format) I had to change the connection strings in order to reproduce the example:
scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\docs\dbto.mdb"
...
& "[Excel 12.0 Xml;HDR=YES;IMEX=2;DATABASE=C:\Docs\WB.xls].[Sheet1$] b " _
EDIT: an example updating access row by row (using arrays)
On Error GoTo ExceptionHandling
With Application
'.EnableEvents = False
.ScreenUpdating = False
End With
Dim cnStr As String, sSQL As String, ArId As Variant, ArPrice As Variant, i As Integer, ws As Worksheet, LastRow as Long
Set ws = Sheets("Sheet1")
cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.Path & "\Test.mdb;Jet OLEDB:Database Password=123"
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.CursorLocation = adUseServer
cn.Open cnStr
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cn
With ws
LastRow = .Cells(1000, 1).End(xlUp).Row
ArId = Application.Transpose(.Range(.Cells(17, 1), .Cells(LastRow, 1)))
ArPrice = Application.Transpose(.Range(.Cells(17, 3), .Cells(LastRow, 3)))
For i = 1 To UBound(ArId)
If ArPrice(i) = "" Then GoTo ContinueLoop
sSQL = "UPDATE PRICES SET Price = " & Replace(ArPrice(i), ",", ".") & " WHERE Id =" & ArId(i)
cmd.CommandText = sSQL
'For statements that don't return records, execute the command specifying that it should not return any records
'this reduces the internal work, so makes it faster
cmd.Execute , , adCmdText + adExecuteNoRecords
'another option using the connection object
'cn.Execute sSQL, RecsAffected
'Debug.Print RecsAffected
ContinueLoop:
Next i
End With
CleanUp:
On Error Resume Next
With Application
'.EnableEvents = True
.ScreenUpdating = True
End With
On Error Resume Next
Set cmd = Nothing
cn.Close
Set cn = Nothing
Exit Sub
ExceptionHandling:
MsgBox "Error: " & Err.Description & vbLf & Err.Number
Resume CleanUp
Below is an example of a reverse update query: updating a table in Excel from the values in Access.
(tested with Office 2007 and ADO 2.8, excel file in .xlsm format and access file in .mdb format)
Sub Update_Excel_from_Access()
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
'different options, tested OK
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"";"
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=Excel 12.0 Xml;"
cn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & ActiveWorkbook.FullName & ";ReadOnly=0;"
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cn
cmd.CommandText = "UPDATE [Sheet1$] a " _
& "INNER JOIN " _
& "[;Database=" & ThisWorkbook.Path & "\data.mdb].[Test] b " _
& "ON a.ID=b.ID " _
& "SET a.Results=b.Results"
cmd.Execute , , adCmdText
'Another option, tested OK
'sSQL = "UPDATE [Sheet1$] a " _
' & "INNER JOIN " _
' & "[;Database=" & ThisWorkbook.Path & "\data.mdb].[Test] b " _
' & "ON a.ID=b.ID " _
' & "SET a.Results=b.Results"
'cn.Execute sSQL, RecsAffected
'Debug.Print RecsAffected
Set cmd = Nothing
cn.Close
Set cn = Nothing
End Sub
Below is the same example but using a recordset object:
Sub Update_Excel_from_Access_with_Recordset()
Dim sSQL As String
On Error GoTo ExceptionHandling
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.CursorLocation = adUseServer
'different options, tested OK
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=YES;"";"
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=Excel 12.0 Xml;"
cn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=" & ActiveWorkbook.FullName & ";ReadOnly=0;"
'Create a recordset object
Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset
sSQL = "SELECT a1.Results As er, a2.Results As ar " _
& "FROM [Sheet1$] a1 INNER JOIN [;Database=" & ThisWorkbook.Path & "\data.mdb].[Test] a2 " _
& " ON a1.[ID] = a2.[ID]"
With rst
.CursorLocation = adUseServer
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open sSQL, cn
If Not rst.EOF Then
Do Until rst.EOF
rst!er = rst!ar
.Update
.MoveNext
Loop
.Close
Else
.Close
End If
End With
CleanUp:
Cancelled = False
On Error Resume Next
cn.Close
Set rst = Nothing
Set cn = Nothing
Exit Sub
ExceptionHandling:
MsgBox "Error: " & Err.description
Resume CleanUp
End Sub