I am trying a couple of things and one is to connect an excel workbook with an AS400 to get the description to a part number in our system but trying to keep the connection open or at least until the workbook is closed.
Does anyone have any suggestions?
Public Sub GetPartNumbers()
Dim myConn As ADODB.Connection
Dim myRS As ADODB.Recordset
'' Dim selVal As String
'' Dim selRow As Integer
Set myConn = New ADODB.Connection
myConn.ConnectionString = "Provider=SEQUEL ViewPoint;"
myConn.Open
Set myRS = New ADODB.Recordset
This is how I do it.
Dim myConn As New ADODB.Connection
Dim myRs As New ADODB.Recordset
On Error GoTo ErrorHandler
con.Open "PROVIDER=IBMDAS400;Data Source=999.999.999.999;USER ID= ;PASSWORD= ;"
Set myRs.ActiveConnection = myConn
End
Exit Sub
ErrorHandler:
MsgBox "Can not connect", vbInformation, cHeading
End
End Sub
I can sympathize with you as I had to figure this out as well before I knew much about VBA. Below is a simple connection and loop through results example. And yes, you shouldn't use Activate but for the sake of this example I through it in.
Note that you should clean up the connection at the end. If you use an error handler than make sure you close any open connections before exiting even after an error.
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Set cnn = New ADODB.Connection
Set rst = New ADODB.Recordset
cnn.Open "PROVIDER=IBMDAS400;Data Source=999.999.999.999;USER ID= ;PASSWORD= ;"
rst.ActiveConnection = cnn
rst.CursorLocation = adUseServer
'Query String (Specific to your database setup)
rst.Source = "SELECT DISTINCT F3002.IXLITM " _
& "FROM WYATT.PRDDTA.F3002 F3002 " _
& "WHERE (F3002.IXKITL='30P') AND (F3002.IXTBM='E')"
rst.Open
Worksheets("Sheet1").Range("A1").Activate
Do Until rst.EOF
ActiveCell.Value = rst.Fields("IXLITM")
rst.MoveNext
ActiveCell.Offset(1, 0).Activate
Loop
'Clean up
rst.Close
Set rst = Nothing
Set cnn = Nothing
Related
I'm trying to learn how to connect to a SQL Server DB from Excel DB. I've tried to reduce the code to dead simple to begin with. I've looked at several answers to related questions, however, I cannot figure out why this doesn't work. It executes all the way through. (The code shown here is somewhat anonymized.)
The query finds the database, because if the table name is invalid it throws an error. However it always returns record count = -1. I can eyeball the table in MSSMS and it has data. Same result for other tables in the DB.
Public Sub ADOtest1()
Dim Conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strConnString As String
strConnString = "Provider='SQLOLEDB'" & ";" & _
"Data Source='XXX-XPS\SQLEXPRESS'" & ";" & _
"Initial Catalog='XXXXX'" & ";" & _
"Integrated Security='SSPI'"
Set Conn = New ADODB.Connection
Conn.Open strConnString
' the query finds the DB, because if the table name is incorrect, it throws an error
strSQLString = "SELECT * from t300_XXXX"
Set rs = Conn.Execute(strSQLString)
wrkRecordCount = rs.RecordCount
'--- just some test breakpoints
If wrkRecordCount = -1 Then
a = "" '--- code keeps arriving here
Else
a = ""
End If
rs.Close
Conn.Close
End Sub
Answer from Srinika below worked:
Set rs = Conn.Execute(strSQLString)
rs.Close
rs.CursorLocation = adUseClient
rs.Open
I'll post two examples, so please refer.
First Example
Sub ExampleSQL()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
Set cnn = New ADODB.Connection
'Set the provider property to the OLE DB Provider for ODBC.
'cnn.Provider = "MSDASQL"
'cnn.Provider = "Microsoft.ACE.OLEDB.12.0"
'cnn.Provider = "MSOLAP"
'cnn.Provider = "SQLOLEDB.1"
' Open a connection using an ODBC DSN.
cnn.ConnectionString = "driver={SQL Server};" & _
"server=severname;uid=sa;pwd=password;database=test"
Set rs = New ADODB.Recordset
strSQL = "SELECT * FROM [your Table] "
rs.Open strSQL, cnn.ConnectionString, adOpenForwardOnly, adLockReadOnly, adCmdText
cnn.Open
If cnn.State = adStateOpen Then
Else
MsgBox "Sever is not connected!! "
Exit Sub
End If
If Not rs.EOF Then
With Ws
.Range("a4").CurrentRegion.ClearContents
For i = 0 To rs.Fields.Count - 1
.Cells(4, i + 1).Value = rs.Fields(i).Name
Next
.Range("a5").CopyFromRecordset rs
.Columns.AutoFit
End With
Else
MsgBox "No Data!!", vbCritical
End If
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
End Sub
Second Example
Sub getDataFromServer()
Dim con As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rs As New ADODB.Recordset
Dim i As Integer
con.ConnectionString = "Provider=SQLOLEDB.1;" _
& "Server=(local);" _
& "Database=TEST;" _
& "Integrated Security=SSPI;" _
& "DataTypeCompatibility=80;"
con.Open
Set cmd.ActiveConnection = con
cmd.CommandText = "SELECT * FROM [your Table]"
Set rs = cmd.Execute
Range("A1").CopyFromRecordset rs
con.Close
Set con = Nothing
End Sub
i have the following code which gets data from a database table with ADODB and outputs to sheet.
I use this a lot, changing between cnn (access / mysql etc....) / different queries.
Is there a way i can create this as a function to minimize repeated code?
Sub getDBdata()
Dim Cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Set Cnn = New ADODB.Connection
Set rs = New ADODB.Recordset
Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\test\TESTDB.MDB"
SQLString = "SELECT * FROM TABLE1"
rs.Open SQLString, Cnn, adLockReadOnly
Sheet1.Range("A2").CopyFromRecordset rs
rs.Close
Cnn.Close
Set Cnn = Nothing
Set rs = Nothing
End Sub
example:
sub getSpecificData()
Connection = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\test\TESTDB.MDB"
SQLString = "SELECT COLUMN1 FROM TABLE1"
OutputLocation = Sheet1.Range("A1")
getDBData Connection, SQLString, OutputLocation
End Sub
Appreciate any help
The simplest thing to do is to add 3 parameters to your sub:
Sub getDBdata(connString as string, SQL as String, rngDest As Range)
Dim Cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Set Cnn = New ADODB.Connection
Set rs = New ADODB.Recordset
Cnn.Open connString
rs.Open SQL, Cnn, adLockReadOnly
rngDest.CopyFromRecordset rs
rs.Close
Cnn.Close
Set Cnn = Nothing
Set rs = Nothing
End Sub
I am trying to create a VBA script that will pull the results from a View (SELECT * FROM view_name) from the RecordSet.Source property, but when attempted, my CloseConnection error handler keeps getting caught. I can get results from a table using a simple query like SELECT * FROM tbl_name with no issues.
Below is the code I am using. Note: my Const variable has the Provider and Database information removed.
I guess it really comes down to is it even possible to get results from a View like I would from a table?
Option Explicit
Const ConStrMSSQL As String = _
"Provider=provider_name;Database=database_name;Trusted_Connection=yes;"
Sub test()
Dim formConnect As ADODB.connection
Dim formData As ADODB.recordSet
Dim formField As ADODB.Field
Set formConnect = New ADODB.connection
Set formData = New ADODB.recordSet
formConnect.ConnectionString = ConStrMSSQL
formConnect.Open
On Error GoTo CloseConnection
With formData
.ActiveConnection = formConnect
.Source = "SELECT * FROM v_data_extract_658"
.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With
On Error GoTo CloseRecordset
Sheets("test").Range("A1").Select
For Each formField In formData.Fields
ActiveCell.Value = formField.Name
ActiveCell.Offset(0, 1).Select
Next formField
Sheets("test").Range("A2").CopyFromRecordset formData
On Error GoTo 0
CloseRecordset:
formData.Close
CloseConnection:
formConnect.Close
End Sub
This is the error message:
run-time error 2147467259 (80004005): unknown token received from SQL Server
I think the big issue here is that you haven't defined a Command Object.
I somewhat put this together "freehand" and for certain, didn't test it but it should get you to where you need to go.
Sub test()
On Error GoTo ErrorHandle:
Dim formConnect As ADODB.Connection
Set formConnect = New ADODB.Connection
formConnect.ConnectionString = ConStrMSSQL
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
formConnect.Open
With cmd
.ActiveConnection = formConnect
.CommandType = adCmdText
.CommandText = "SELECT * FROM v_data_extract_658"
.CommandTimeout = 30
End With
Dim formData As ADODB.Recordset
Set formData = New ADODB.Recordset
formData.Open cmd, , adOpenStatic, adLockReadOnly
Sheets("test").Range("A1").Select
Dim formField As ADODB.Field
For Each formField In formData.Fields
ActiveCell.value = formField.Name
ActiveCell.Offset(0, 1).Select
Next formField
Range("A2").CopyFromRecordset formData
On Error GoTo 0
Cleanup:
If Not formData Is Nothing Then
If formData.State <> adStateClosed Then formData.Close
Set formData = Nothing
End If
If Not formConnect Is Nothing Then
If formConnect.State <> adStateClosed Then formConnect.Close
Set formConnect = Nothing
End If
Set cmd = Nothing
Exit Sub
ErrorHandle:
MsgBox Err.Description
'Do whatever else is needed to respond to errors.
Resume Cleanup
End Sub
Using Excel & VBA to fetch dta from SLQ Server is quite easy (not always, but these days).
Sub ADOExcelSQLServer()
' Carl SQL Server Connection
'
' FOR THIS CODE TO WORK
' In VBE you need to go Tools References and check Microsoft Active X Data Objects 2.x library
'
Dim Cn As ADODB.Connection
Dim Server_Name As String
Dim Database_Name As String
Dim User_ID As String
Dim Password As String
Dim SQLStr As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Server_Name = "EXCEL-PC\SQLEXPRESS" ' Enter your server name here
Database_Name = "NORTHWND" ' Enter your database name here
User_ID = "" ' enter your user ID here
Password = "" ' Enter your password here
SQLStr = "SELECT * FROM [Customers]" ' Enter your SQL here
Set Cn = New ADODB.Connection
Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
rs.Open SQLStr, Cn, adOpenStatic
' Dump to spreadsheet
For iCols = 0 To rs.Fields.Count - 1
Worksheets("Sheet1").Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
With Worksheets("sheet1").Range("a2:z500") ' Enter your sheet name and range here
'.ClearContents
.CopyFromRecordset rs
End With
' Tidy up
rs.Close
Set rs = Nothing
Cn.Close
Set Cn = Nothing
End Sub
As an aside, you can try this as well (please change to suit your specific setup/configuration)...
Sub Working2()
Dim con As Connection
Dim rst As Recordset
Dim strConn As String
Set con = New Connection
strConn = "EXCEL-PC\SQLEXPRESS;Database=Northwind;Trusted_Connection=True"
con.Open strConn
'Put a country name in Cell E1
Set rst = con.Execute("Exec dbo.MyOrders '" & ActiveSheet.Range("E1").Text & "'" & ActiveSheet.Range("E2").Text & "'")
'The total count of records is returned to Cell A5
ActiveSheet.Range("A5").CopyFromRecordset rst
rst.Close
con.Close
End Sub
Please see the link below for more details.
https://www.excel-sql-server.com/excel-sql-server-import-export-using-vba.htm#Excel%20Data%20Export%20to%20SQL%20Server%20Test%20Code
Using the following code I open a connection with SQL server and drop the results straight into an array. My problem is that I get an error for the rowcount, which I need to redim my array. The error I get is on the line indicated below and reads
"rowset does not support fetching backward"
All answers I can find suggest the cursor type as the problem, but I have changed this as far as I can tell. Apologies for the long code, I felt it best to leave the start in.
Function ConnectServer() As String()
'Working SQL Server connection
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConnString As String
Dim strSqlQuery As String
Dim iCols As Long
' Create the connection string.
sConnString = "Provider=SQLOLEDB;Data Source=wait;" & _
"Initial Catalog=what;" & _
"User Id=foo;" & _
"Password=bar;"
' Create the Connection and Recordset objects.
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
rs.CursorType = adOpenDynamic
rs.CursorLocation = adUseClient
conn.CommandTimeout = 50
' Open the connection and execute.
conn.Open sConnString
' Debug.Print strSqlQuery
Set rs = conn.Execute("SELECT DISTINCT a FROM b")
' Check we have data.
If Not rs.EOF Then
'*****************Problem here********************
rs.MoveLast
Debug.Print rs.RecordCount
'Read into array and cleanup...
End If
End Function
I don't believe this to be a duplicate of this question:
Rowset does not support scrolling backward
Because I already incorporated the answer into my code and the problem still persists.
The problem is caused by using conn.Execute to fill the recordset. Setting the recordset's activeconnection to the ADODB.Connection and using the recordset's open method will fix the issue.
Function ConnectServer() As String()
'Working SQL Server connection
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConnString As String
Dim strSqlQuery As String
Dim iCols As Long
' Create the connection string.
sConnString = "Provider=SQLOLEDB;Data Source=wait;" & _
"Initial Catalog=what;" & _
"User Id=foo;" & _
"Password=bar;"
' Create the Connection and Recordset objects.
Set conn = New ADODB.Connection
conn.ConnectionString = sConnString
conn.Open
Set rs = New ADODB.Recordset
With rs
.ActiveConnection = conn
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.Source = "SELECT * FROM b"
.Open
End With
' Check we have data.
If Not rs.EOF Then
rs.MoveLast
Debug.Print rs.RecordCount
'Read into array and cleanup...
End If
End Function
You can use Recordset.GetRows() to fill the array. No need to dim it. GetRows Method (ADO)
I am working on quering a database on a remote server and have my results in the excel spreadsheet. Say in Column A.
For that reason, I have created a button to allow for an 'at will' action and start setting up my ADODB objects.
The connection to the database is fine, however it is very unclear to me how to set up the .Recordset object (MyOutput) to output the results of my query in Column A. Here is my code:
Private Sub RunQuery_Click()
Dim MyOutput As ADODB.Recordset
Dim cnn As New ADODB.Connection
Dim myCommand As ADODB.Command
Dim stringSQL As String
Dim stringConn As String
cnn.Provider = "Microsoft.Jet.OLEDB.4.0;"
cnn.Properties("Jet OLEDB:System database") = "My path"
stringConn = "Data Source=\'my path';User Id='';Password='';"
cnn.Open stringConn
Set myCommand = New ADODB.Command
myCommand.ActiveConnection = cnn
stringSQL = " My query"
myCommand.CommandText = stringSQL
myCommand.Execute
cnn.Close
Set cnn = Nothing
End Sub
May I have some help here?
Thank you very much for your time guys!
You can use something like the below to do it:
Public Sub RunQuery_Click()
Dim oDB As ADODB.Connection
Dim oCM As ADODB.Command
Dim oRS As ADODB.Recordset
Dim strConn As String
Set oDB = New ADODB.connectoin
With oDB
.Provider = "Microsoft.Jet.OLEDB.4.0;"
.Properties("Jet OLEDB:System database") = "My path"
strConn = "Data Source=\'my path';User Id='';Password='';"
.Open strConn
End With
Set oCM = New ADODB.Command
With oCM
.ActiveConnection = oDB
.CommandText = "My Query"
.CommandType = adCmdText
Set oRS = .Execute
End With
Sheets(1).Range("A1").CopyFromRecordset oRS
oRS.Close
Set oRS = Nothing
oDB.Close
Set oDB = Nothing
End Sub
Alternativly, if you wish to return the field names as well, you could use:
Public Sub RunQuery_Click()
Dim oDB As ADODB.Connection
Dim oCM As ADODB.Command
Dim oRS As ADODB.Recordset
Dim strConn As String
Dim iCols As Long
Set oDB = New ADODB.connectoin
With oDB
.Provider = "Microsoft.Jet.OLEDB.4.0;"
.Properties("Jet OLEDB:System database") = "My path"
strConn = "Data Source=\'my path';User Id='';Password='';"
.Open strConn
End With
Set oCM = New ADODB.Command
With oCM
.ActiveConnection = oDB
.CommandText = "My Query"
.CommandType = adCmdText
Set oRS = .Execute
End With
For iCols = 0 To oRS.Fields.Count - 1
Sheet(1).Cells(1, iCols + 1).Value = oRS.Fields(iCols).Name
Next
Sheets(1).Range("A2").CopyFromRecordset oRS
oRS.Close
Set oRS = Nothing
oDB.Close
Set oDB = Nothing