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
Related
I have this bit of code that I found online that will import access records into excel. strFilePath is the filepath for the MDB and strTableName is the table name I am looking to import
Sub importAccessdata()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sQRY As String
Dim strFilePath As String
strFilePath = Sheets("Setup").Range("C2").Value
strTableName = Sheets("Setup").Range("C4").Value
Set cnn = New ADODB.Connection
Set rs = New ADODB.Recordset
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strFilePath & ";"
sQRY = "SELECT * FROM " & strTableName & ""
rs.CursorLocation = adUseClient
rs.Open sQRY, cnn, adOpenStatic, adLockReadOnly
Application.ScreenUpdating = False
Sheet3.Range("A1").CopyFromRecordset rs
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
Exit Sub
End Sub
All of the records import very fast however I cannot get the field names to populate with them! Is there a simple modification I can do to carry the field names with the data?
This is what I use-
Private Sub PullSummaryData()
Const strDb As String = "C:\db\AccessDatabase.accdb"
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Dim i As Integer
Sheets("Summary").Select
Const strQry As String = "SELECT * FROM [AccessDataTable]"
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDb & ";"
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Open strQry
End With
With Sheets("Summary")
For i = 1 To rs.Fields.Count
.Cells(2,i).Value = rs.Fields(i-1).Name 'fields is a 0 based collection
Next i
.Range("A3").CopyFromRecordset rs
End With
rs.Close
cn.Close
End Sub
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)
Noob here. This vba code in excel is supposed to connect to sql 2008 using ADO, run the query and populate sheet1 in excel. Now, the heading error keeps popping up On this line
" Sheet1.Range("A1").CopyFromRecordset rst".
Sub Code1()
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim SqlQuery As String
Application.ScreenUpdating = False
Const stADO As String = "Provider=SQLOLEDB.1;Password=NOPWDHERE;Persist Security Info=True;User ID=sa;Initial Catalog=StockControl;Data Source= PCSMIS01"
Set wbBook = ActiveWorkbook
Set WsSheet = wbBook.Worksheets(1)
SqlQuery = " SELECT * FROm dbo.Site "
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
With cnt
.CursorLocation = adUseClient
.Open stADO
.CommandTimeout = 0
Set rst = .Execute(SqlQuery)
End With
Sheet1.Range("A1").CopyFromRecordset rst
'With rst
' .ActiveConnection = cnt
' .Open SqlQuery
' Sheet1.Range("A1").CopyFromRecordset rst
' .Close
'End With
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
End Sub
I have also tried an alternative by using the piece of commented code to copy the data into the sheet.I have researched similar topics on the internet to the best of my ability, but i am more confused now. Please help.
Replace Sheet1 (it isn't referenced) by WsSheet :
Sub Code1()
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim SqlQuery As String
Application.ScreenUpdating = False
Const stADO As String = "Provider=SQLOLEDB.1;Password=NOPWDHERE;Persist Security Info=True;User ID=sa;Initial Catalog=StockControl;Data Source= PCSMIS01"
Set wbBook = ActiveWorkbook
Set WsSheet = wbBook.Worksheets(1)
SqlQuery = " SELECT * FROm dbo.Site "
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
With cnt
.CursorLocation = adUseClient
.Open stADO
.CommandTimeout = 0
Set rst = .Execute(SqlQuery)
End With
WsSheet.Range("A1").CopyFromRecordset rst
'With rst
' .ActiveConnection = cnt
' .Open SqlQuery
' Sheet1.Range("A1").CopyFromRecordset rst
' .Close
'End With
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
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