I have a macro in Excel tied to a command button on one of my worksheets. When clicked, I'm trying to have the data from my worksheet "FeedSamples" be exported into an Access Database Table called "ImportedData".
Can anyone assist me? I've tried multiple examples from the net with no luck. This is what I have right now but keep receiving "Run-time error '3343': Unrecognized database format 'filePath\FeedSampleResults.accdb
Dim db As Database
Dim rs As Recordset
Dim r As Long
Set db = OpenDatabase("filePath\FeedSampleResults.accdb")
Set rs = db.OpenRecordset("ImportedData", dbOpenTable)
r = 2
Do While Len(Worksheets("FeedSamples").Range("A" & r).Formula) > 0
With rs
.AddNew
.Fields("REPTNO") = Worksheets("FeedSamples").Range("B" & r).value
.Update
End With
r = r + 1
Loop
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
Once I get this accomplished, I need to code to have the Access Table export the Data into a dBase file.
Here's the code using ADO. You need to set the full path of your access database in Data Source.
Sub ExcelToAccessAdo()
Dim cn As ADODB.Connection, rs As ADODB.Recordset, row As Long
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=filePath\FeedSampleResults.accdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "ImportedData", cn, adOpenKeyset, adLockOptimistic, adCmdTable
row = 3 ' the start row in the worksheet
Do While Not IsEmpty(Worksheets("FeedSamples").Range("A" & row))
With rs
.AddNew ' create a new record
.Fields("REPTNO") = Worksheets("FeedSamples").Range("A" & row).Value
.Update
End With
row = row + 1
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Related
Im making Codes Inserting Data into a autonumber Columns to a table that composes of Two COlumns.
My Table is Access and Front End is Excel. My Access Table contains ID (which is AutoNumber) and Paycode which is base on a cell. I need this codes to use it as Unique IDs in which later on will post it back to Ms Access separate Table.
Sub ImportJEData()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath
Dim x As Long
Dim var
Dim PayIDnxtRow As Long
'add error handling
On Error GoTo errHandler:
'Variables for file path and last row of data
dbPath = Sheets("Update Version").Range("b1").Value
Set var = Sheets("JE FORM").Range("F14")
PayIDnxtRow = Sheets("MAX").Range("c1").Value
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Create the ADODB recordset object.
'Set rst = New ADODB.Recordset 'assign memory to the recordset
'Connection class is equipped with a —method— named Open
'—-4 aguments—- ConnectionString, UserID, Password, Options
'ConnectionString formula—-Key1=Value1;Key2=Value2;Key_n=Value_n;
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
'two primary providers used in ADO SQLOLEDB —-Microsoft.JET.OLEDB.4.0 —-Microsoft.ACE.OLEDB.12.0
'OLE stands for Object Linking and Embedding, Database
Do
On Error Resume Next 'reset Err.obj.
'Get the Max ID +1
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "SELECT Max(ApNumber)+1 FROM PayVoucherID "
rst.Open SQL, cnn
'Check if the recordset is empty.
If rst.EOF And rst.BOF Then
'Close the recordet and the connection.
Sheets("Max").Range("A2") = 1
Else
'Copy Recordset to the Temporary Cell
Sheets("MAX").Range("A2").CopyFromRecordset rst
End If
'Insert the Data to Database And Check If no Errors
Sql2 = "INSERT INTO PayVoucherID(ApNumber)Values('" & Sheets("MAX").Range("A2") & "') "
cnn.Execute Sql2
Loop Until (Err.Number = 0)
'And if No errors COpy temporary to NEw Sub Temporary Data for Reference
Sheets("LEDGERTEMPFORM").Range("D1").Value = Sheets("MAX").Range("A2").Value
'Securing ChckID Seq Number
'ADO library is equipped with a class named Recordset
For x = 1 To PayIDnxtRow
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.AddNew
'Insert the Data to Database And Check If no Errors
Sql2 = "INSERT INTO PayPaymentID(ApNumber)Values('" & Sheets("LEDGERTEMPFORM").Range("B2") & "') "
cnn.Execute Sql2
Next x
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "Select PayID From PayPaymentID where APNumber = " & Sheets("LEDGERTEMPFORM").Range("B2") & " order by PayID "
rst.Open SQL, cnn
Sheets("PaySeries").Range("B2").CopyFromRecordset rst
Set rst = Nothing
rst.Close
' Close the connection
cnn.Close
'clear memory
Set rst = Nothing
Set cnn = Nothing
'communicate with the user
'MsgBox " The data has been successfully sent to the access database"
'Update the sheet
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
errHandler:
'clear memory
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
In this section Below Would like to know if theres another way without using or even faster type of loop.
'Securing ChckID Seq Number
'ADO library is equipped with a class named Recordset
For x = 1 To PayIDnxtRow
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.AddNew
'Insert the Data to Database And Check If no Errors
Sql2 = "INSERT INTO PayPaymentID(ApNumber)Values('" & Sheets("LEDGERTEMPFORM").Range("B2") & "') "
cnn.Execute Sql2
Next x
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "Select PayID From PayPaymentID where APNumber = " & Sheets("LEDGERTEMPFORM").Range("B2") & " order by PayID "
rst.Open SQL, cnn
Sheets("PaySeries").Range("B2").CopyFromRecordset rst
Finally Ive figured it Out it went better from 40 to 19s Thanks to the idea of #miki180.
Heres my code below starting from DO...
Do
On Error Resume Next 'reset Err.obj.
'Get the Max ID +1
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "SELECT Max(ApNumber)+1 FROM PayVoucherID "
rst.Open SQL, cnn
'Check if the recordset is empty.
'Copy Recordset to the Temporary Cell
Sheets("MAX").Range("A2").CopyFromRecordset rst
'Insert the Data to Database And Check If no Errors
Sql2 = "INSERT INTO PayVoucherID(ApNumber)Values('" & Sheets("MAX").Range("A2") & "') "
cnn.Execute Sql2
Loop Until (Err.Number = 0)
xlFilepath = Application.ThisWorkbook.FullName
SSql = "INSERT INTO PaypaymentID(Apnumber) " & _
"SELECT * FROM [Excel 12.0 Macro;HDR=YES;DATABASE=" & xlFilepath & "].[MAX$G1:G15000] where APNumber > 1"
cnn.Execute SSql
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "Select PayID From PayPaymentID where APNumber = " & _
Sheets("LEDGERTEMPFORM").Range("B8") & " order by PayID "
rst.Open SQL, cnn
Sheets("PaySeries").Range("B2").CopyFromRecordset rst
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
I'm trying to get data that is produced from a SQL Stored Procedure to be appended on to the end of existing data within my excel spreadsheet using VBA. I want it pasted to the right of the last column. Each time I run it i get the error above: "Method 'Range' of object '_Global' failed.
I would like the new data pasted into row 3 to the right of the existing data. Below is my vba code:
Sub RefreshStatus()
Dim db As DAO.Database
Dim con As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim StoredProc As String
Dim RWS As Worksheet
Dim DWS As Worksheet
Dim ServerName As String
Dim DatabaseName As String
Dim StoredProcedure As String
Set con = New ADODB.Connection
Set cmd = New ADODB.Command
Set rs = New ADODB.Recordset
Set RWS = Worksheets("Refresh")
Set DWS = Worksheets("141215")
Application.DisplayStatusBar = True
Application.StatusBar = "Contacting SQL Server..."
RWS.Activate
ServerName = "tns-reports-01" ' Enter your server name here
DatabaseName = "GroupPerformance" ' Enter your database name here
StoredProcedure = "JM_Recruitment_Status_141215" ' Enter Stored Procedure here
con.Open "Provider=SQLOLEDB;Data Source=" & ServerName & ";Initial Catalog=" & DatabaseName & ";Trusted_Connection=yes"
cmd.ActiveConnection = con
Application.StatusBar = "Running stored procedure..."
cmd.CommandTimeout = 0
cmd.CommandText = StoredProcedure
Set rs = cmd.Execute(, , adCmdStoredProc)
' Copy the results to cell A1 on the first Worksheet
DWS.Activate
Dim Lastcol As Long
Lastcol = Range("3" & Columns.Count).End(xlRight).Row
If rs.EOF = False Then DWS.Cells(2, 1).CopyFromRecordset rs
rs.Close
Set rs = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
Application.StatusBar = "Data successfully updated."
End Sub
If anybody could help me out, I would greatly appreciate it.
Many thanks.
You made some errors when trying to find the last non-empty column and some other minor errors.
Below is your code with a few changes (changes are described in comments).
I have assumed that your recordset contains only one field and many records and
you want to paste all those records horizontally from cell _3 to the right where _ is the first empty column.
Sub RefreshStatus()
Dim db As DAO.Database
Dim con As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim StoredProc As String
Dim RWS As Worksheet
Dim DWS As Worksheet
Dim ServerName As String
Dim DatabaseName As String
Dim StoredProcedure As String
Set con = New ADODB.Connection
Set cmd = New ADODB.Command
Set rs = New ADODB.Recordset
Set RWS = Worksheets("Refresh")
Set DWS = Worksheets("141215")
With Application
.DisplayStatusBar = True
.StatusBar = "Contacting SQL Server..."
End With
'NOTE: You don't have to activate worksheet to operate on its ranges.
'Actually, you shouldn't do that, since it's time-consuming, make the
'user experience worst and can cause errors in specific cases.
'Additionaly, I can't see where you use RWS worksheet later in the code.
'RWS.Activate
ServerName = "tns-reports-01" ' Enter your server name here
DatabaseName = "GroupPerformance" ' Enter your database name here
StoredProcedure = "JM_Recruitment_Status_141215" ' Enter Stored Procedure here
con.Open "Provider=SQLOLEDB;Data Source=" & ServerName & ";Initial Catalog=" & DatabaseName & ";Trusted_Connection=yes"
cmd.ActiveConnection = con
Application.StatusBar = "Running stored procedure..."
cmd.CommandTimeout = 0
cmd.CommandText = StoredProcedure
Set rs = cmd.Execute(, , adCmdStoredProc)
' Copy the results to cell A1 on the first Worksheet
'Again, it is not necessary to activate worksheet.
'DWS.Activate
Dim lastCol As Long
'If rs.EOF = False Then DWS.Cells(2, 1).CopyFromRecordset rs
row = 3
lastCol = DWS.Cells(row, DWS.Columns.Count).End(xlRight).Column + 1
Do Until rs.EOF
DWS.Cells(row, lastCol).value = rs.Fields(0).value
row = row + 1
Call rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set cmd = Nothing
con.Close
Set con = Nothing
Application.StatusBar = "Data successfully updated."
End Sub
I am having problem with copying records from an Access table to an excel worksheet using Excel vba.
After the docmd opens the table I'm lost!!!!!!
Can someone help Pleassssssseeeeee?
Thanks
Here is my code:
Sub OpenAccessDB()
Dim DBFullPath As String
Dim DBFullName As String
Dim TableName As String
Dim TargetRange As Range
Dim appAccess As Object
Dim RS As New ADODB.Recordset
'File Paths and Names*********************************
DBFullPath = "e:\ccampbellStuff\"
DBFullName = "2015_02.accdb"
TableName = "Record Opt Outs"
'Initiating the Access DB Engine**********************
Set appAccess = CreateObject("Access.Application")
'Opening the database
appAccess.OpenCurrentDatabase (DBFullPath & DBFullName)
appAccess.Visible = True
'Open Access Table Called Record Opt Outs****
**appAccess.DoCmd.Opentable (TableName)**
'Set RS = appAccess.DoCmd.Opentable (TableName) this didnt work either
'Set appAccess = Nothing
'Copy Access Records and Patse to Excel''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Close database
appAccess.Quit
End Sub
I wouldn't bother automating Access itself - just use ADO:
Sub loadAccessData()
'////////////////////////////////////////////////////////////////////
' requires a reference to a Microsoft ActiveX Data Objects Library.
'////////////////////////////////////////////////////////////////////
Dim cn As ADODB.Connection
Dim sQuery As String
Dim rs As ADODB.Recordset
Dim sDB_Path As String
Dim ws As Worksheet
' output to activesheet
Set ws = ActiveSheet
' Path to database
sDB_Path = "c:\somepath\database1.accdb"
Set cn = New ADODB.Connection
' open connection to database
With cn
.CursorLocation = adUseServer
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & sDB_Path & ";"
.Open
End With
' SQL query string - change to suit
sQuery = "SELECT * FROM tblTest"
' Create New Recordset
Set rs = New ADODB.Recordset
' open recordset using query string and connection
With rs
.Open sQuery, cn, adOpenStatic, adLockPessimistic, adCmdText
' check for records returned
If Not .EOF Then
'Populate field names
For i = 1 To .Fields.Count
ws.Cells(1, i) = .Fields(i - 1).Name
Next i
' Load data starting at A2
ws.Cells(2, 1).CopyFromRecordset rs
End If
.Close
End With
' clean up
cn.Close
End Sub
Is there a way to get the number of rows of recordset without using the movelast method in VBA? If I try to use the movelast method, the function will stop as i am using the UDF.
Yes, but you have to open the Recordset using adOpenStatic or adOpenKeyset. Using adOpenStatic will pull the entire Recordset into memory, so it's not a good idea if your application doesn't need to process the entire recordset, you need to view changes made by other users, or if it's too big to fit into memory. On the other hand, processing the Recordset can be much faster because it doesn't have to hit the database for each record.
adOpenStatic example:
' dbConnection is an ADODB.Connection object
rs.Open "source", dbConnection, adOpenStatic
Debug.Print rs.RecordCount
adOpenKeyset example:
rs.Open "source", dbConnection, adOpenKeyset
' note: LockType adLockOptimistic may be required for particular databases
' rs.Open "source", dbConnection, adOpenKeyset, adLockOptimistic
Upon reviewing BzKnt's answer, it appears that another option to gain access to RecordCount is to set the CursorLocation to adUseClient.
Dim rs As New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open "source", dbConnection
Also note that this is dependent on the database and driver you are using. Some of these methods may not work for all types of databases.
Article here http://www.geeksengine.com/article/recordcount-ado-recordset-vba.html explains the issue very clearly.
Use VBA to get the correct number of records in a Recordset object
Issue involves the cursor used.
In short add this after setting:
rs = New ADODB.Recordset
' Client-side cursor
rs.CursorLocation = adUseClient
In case anyone is interested in a working example:
'Query a closed excel workbook and assign a column to a array.
Sub TestADO()
Dim MeArr() As Variant
MeArr = ADOLoader ("C:\Closed_Workbook.xlsx", "Sheet1", "Column One")
Debug.Print LBound(MeArr), MeArr(LBound(MeArr))
Debug.Print UBound(MeArr), MeArr(UBound(MeArr))
End Sub
' SubIDCol is the column header
Function ADOLoader(strSourceFile As String, SheetName As String, SubIDCol As String) As Variant
Dim RowPlace, f As Integer
Dim cn As Object, rs As Object, sql As String
Dim ACount As Integer
Dim SubIDArray() As Variant
sql = "Select [" & SubIDCol & "] from [" & SheetName & "$]"
'---Connecting to the Data Source---
Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & strSourceFile & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
.CursorLocation = adUseClient
.Open
Set rs = .Execute(sql)
End With
' If you wanted the Headers:
' For f = 0 To rs.Fields.Count - 1
' On Error Resume Next
' .Cells(r, c + f).Formula = rs.Fields(f).Name
' Debug.Print rs.Fields(f).Name
' On Error GoTo 0
' Next f
RowPlace = 0
ACount = rs.RecordCount - 1
ReDim SubIDArray(rs.RecordCount - 1)
On Error Resume Next
rs.MoveFirst
On Error GoTo 0
Do While Not rs.EOF
For f = 0 To rs.Fields.Count - 1
On Error Resume Next
SubIDArray(RowPlace) = rs.Fields(f).Value
RowPlace = RowPlace + 1
On Error GoTo 0
Next f
rs.MoveNext
Loop
'---Clean up---
rs.Close
cn.Close
Set cn = Nothing
Set rs = Nothing
Debug.Print "Lower bound of array = " & LBound(SubIDArray)
Debug.Print "Upper bound of array = " & UBound(SubIDArray)
ADOLoader = SubIDArray()
End Function