Access Table to Specific Excel Spreadsheet - vba

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

Related

Export Data From MS Access to MS Excel ListBox

I have a working VBA code that exports data from MS Access data and pastes it into MS Excel Sheet cells and using cell range as RowSource to appear data in the ListBox.
Is there a way to paste directly the imported data into ListBox instead of pasting into Sheet cells?
Sub IBDocsLibSearch()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rs As ADODB.Recordset 'dim the ADO recorset class
Dim dbPath As String
Dim MyDbPassword As String
Dim SQL As String
Dim i As Integer
Dim var1
Application.ScreenUpdating = False
IBDocLibSheet.Range("A2:I500000").ClearContents
dbPath = LinkSheet.Range("C4").Value 'Inbound Checklist Database Location
MyDbPassword = PWSheet.Range("C3").Value 'Password to connect the Excel to Access
Set var1 = IBUserForm.IBDTextSerialNo
'Initialise the collection class variable
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";Jet OLEDB:Database Password=" & MyDbPassword
SQL = "SELECT * FROM DB_IBDocuments WHERE SerialNo = '" & var1.Value & "'"
Set rs = New ADODB.Recordset
rs.Open SQL, cnn
If rs.EOF And rs.BOF Then
'Close the recordset and connection
rs.Close
cnn.Close
'Clear Memory
Set rs = Nothing
Set cnn = Nothing
Application.ScreenUpdating = True
Exit Sub
End If
IBDocLibSheet.Range("A2").CopyFromRecordset rs '----This is where to paste the extracted data
'To show results in Listbox
IBUserForm.IBDListBox.RowSource = "IBL_DocLib"
'Close the recorset and connections
rs.Close
cnn.Close
'Clear memory
Set rs = Nothing
Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

Using VBA to query a VIEW from SQL Server

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

VBA Run-time error '1004'

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

Export Excel Worksheet to Access Table (.accdb)

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

Why ADO VBA code returns only 6559 records?

I try to make macro that operate with sql statements with ADO liblary, but actually it returns only 6559 records, while one of my table have 72k records.
Why?
Recently, I've noticed, that actually my code does not returns 6559, but rows number - 65537. So when I decrease number of the rows in sheet to 72092, I even gets less rows (6550).
Another thing I noticed is that rs.RecordCount returns "-1".
Here is code for my subproccedure. It have three parameters: sql statement (sqlstmt), destination sheet name (sheet_name) and destination range (destination1).
'subprocedure that execute sql statements and save resault in given worksheet
Public Sub sql_query(ByVal sqlstmt As String, ByVal sheet_name As String, ByVal destination1 As String)
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim connstring As String
Dim qt As QueryTable
Dim tw_path As String
Dim is_name As Boolean
Dim sh As Worksheet
'''making sheet if it doesn't exist
is_name = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name = sheet_name Then is_name = True
Next
If is_name = False Then ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)).Name = sheet_name
''' connection
tw_path = ThisWorkbook.path & "\" & ThisWorkbook.Name
connstring = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & tw_path & ";Extended Properties=Excel 8.0;Persist Security Info=False"
Set conn = New ADODB.Connection
conn.ConnectionString = connstring
conn.Open
'''executing statement
Set rs = New ADODB.Recordset
rs.Source = sqlstmt
rs.ActiveConnection = conn
rs.Open
'''saving records
ThisWorkbook.Worksheets(sheet_name).Activate
Set qt = Worksheets(sheet_name).QueryTables.Add(Connection:=rs, Destination:=Range(destination1))
qt.Refresh
'''end
If rs.State <> adStateClosed Then rs.Close
conn.Close
If Not rs Is Nothing Then Set rs = Nothing
If Not conn Is Nothing Then Set conn = Nothing
Set qt = Nothing
End Sub
Thanks for help
I'm guessing you are using excel 2003 or a prior version, in which case a worksheet has a maximum of 65,536 rows. I would've put this in a comment instead of an answer but I'm 1 rep short of being able to comment :(. Sorry