Previously I have an Excel program that uses macro to perform an SQL query within the Excel itself.
Public Sub QueryWorksheet(szSQL As String, rgStart As Range, wbWorkBook As String)
Dim rsData As ADODB.Recordset
Dim szConnect As String
On Error GoTo ErrHandler
Application.StatusBar = "Retrieving data ....."
'Set up the connection string to excel - thisworkbook
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & wbWorkBook & ";" & _
"Extended Properties=Excel 8.0;"
Set rsData = New ADODB.Recordset
'Run the query as adCmdText
rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, adCmdText
'Check if data is returned
If Not rsData.EOF Then
'if the recordset contains data put them on the worksheet
rgStart.CopyFromRecordset rsData
Else
' MsgBox "There's no records that matches the query !!", vbCritical
End If
'Close connection
rsData.Close
'Clean up and get out
Set rsData = Nothing
Application.StatusBar = False
Exit Sub
ErrHandler:
'an error occured in the SQL-statement
MsgBox "Your query could not be executed, the SQL-statement is incorrect."
Set rsData = Nothing
Application.StatusBar = False
End Sub
On my old PC it worked fine. But now that I've changed to a new laptop I keep having problems with the macro. As it goes straight to error handler the moment it passes the line rsData.Open szSQL, szConnect, adOpenForwardOnly, adLockReadOnly, adCmdText.
I checked the References and made sure ActiveX Data Objects was selected. But still no dice.
What else am I possible missing here?
Related
I have been using the below code which I have got from one of website, however, the user always tend to forget to check whether the data (IDs) are already sent to the Access Database, is there any way to loop the process and still export the data and change the font color of item not processed and introduce a new column with text "Not Imported"?
Sub Export_Data()
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, i As Long
Dim nextrow As Long
'add error handling
On Error GoTo errHandler:
'On Error Resume Next
'Variables for file path and last row of data
dbPath = ActiveSheet.Range("I3").Value
nextrow = Cells(Rows.Count, 1).End(xlUp).Row
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Check for data
If Sheet1.Range("A2").Value = "" Then
MsgBox " Add the data that you want to send to MS Access"
Exit Sub
End If
'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
'ADO library is equipped with a class named Recordset
Set rst = New ADODB.Recordset 'assign memory to the recordset
'ConnectionString Open '—-5 aguments—-
'Source, ActiveConnection, CursorType, LockType, Options
rst.Open Source:="PhoneList", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
'you now have the recordset object
'add the values to it
For x = 2 To nextrow
rst.AddNew
For i = 1 To 7
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
Next x
'close the recordset
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
'show the next ID
'Sheet1.Range("J3").Value = Sheet1.Range("K3").Value + 1
'Clear the data
'Sheet1.Range("A2:G1000").ClearContents
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
Appreciate any help, as I don't know how to begin with the loop resume next. I hope you guys can help me change or modify this code.
After reading the Code, I think I finally understood what you wanted to do:
You wanted to check first if the Row has been exported or not before proceeding
So here is the updated Script.
I changed the sequence of several sections of the code as they were not coherent or will cause you errors.
I added a Column H supposing your columns are A to G, where H will store «Exported» after it has been successfully stored on the Database.
So this should work for you now:
Main Sub Exporting to Access
Sub Export_Data_Updated()
Dim dbPath As String
Dim lastRow As Long
Dim exportedRowCnt As Long
'add error handling
On Error GoTo exitSub
'Check for data
'##> This should be first as it is useless to open cnx or find path/last row if this will exit the sub
If Sheet1.Range("A2").Value = "" Then
MsgBox " Add the data that you want to send to MS Access"
Exit Sub
End If
'##> Only Continue when the above is fine
'##> Check if the path exits first
'Variables for file path
dbPath = ActiveSheet.Range("J3").Value '##> This was wrong before pointing to I3
If Not FileExists(dbPath) Then
MsgBox "The Database file doesn't exist! Kindly correct first"
Exit Sub
End If
'##> Only then that you can proceed
'find las last row of data
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
'##> Change the Error handler now
Dim cnx As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset class
On Error GoTo errHandler
'Initialise the collection class variable
Set cnx = New ADODB.Connection
'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;
cnx.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
'ADO library is equipped with a class named Recordset
Set rst = New ADODB.Recordset 'assign memory to the recordset
'ConnectionString Open '—-5 aguments—-
'Source, ActiveConnection, CursorType, LockType, Options
rst.Open Source:="PhoneList", ActiveConnection:=cnx, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
'##> Continue reading Database now
'you now have the recordset object
'add the values to it
'Wait Cursor
Application.Cursor = xlWait
'Pause Screen Update
Application.ScreenUpdating = False
'##> Set exportedRowCnt to 0 first
exportedRowCnt = 0
'##> Let's suppose Data is on Column A to G.
' --> So let's put the "Exported" on Column H
For nRow = 2 To lastRow
'##> Check if the Row has already been imported?
'If it it isn't then continue
If IdExists(cnx, Range("A" & nRow).Value) Then
'Item already exported, so update the Status
Range("H" & nRow).Value2 = "Exported"
Else
rst.AddNew 'Add New RecordSet
'Itirating Columns
For nCol = 1 To 7
rst.Fields(Cells(1, nCol).Value2) = Cells(nRow, nCol).Value 'Using the Excel Sheet Column Heading
Next nCol
rst.Update 'Update RecordSet
'##>Update the Status on Column H when the record is successfully updated
Range("H" & nRow).Value2 = "Exported"
'Increment exportedRowCnt
exportedRowCnt = exportedRowCnt + 1
End If
Next nRow
'close the recordset
rst.Close
' Close the connection
cnx.Close
'clear memory
Set rst = Nothing
Set cnx = Nothing
If exportedRowCnt > 0 Then
'communicate with the user
MsgBox exportedRowCnt & " row(s) successfully sent to the access database"
End If
'Update the sheet
Application.ScreenUpdating = True
exitSub:
'Restore Default Cursor
Application.Cursor = xlDefault
'Update the sheet
Application.ScreenUpdating = True
Exit Sub
errHandler:
'clear memory
Set rst = Nothing
Set cnx = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
Resume exitSub
End Sub
Function Checking if File Exists:
NB: Now valid ID is only String Type
Function IdExists(cnx As ADODB.Connection, sId As String) As Boolean
'##> Set IdExists as False and change to true if the ID exists already
IdExists = False
'##> Change the Error handler now
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim cmd As ADODB.Command 'dim the ADO command class
On Error GoTo errHandler
'Sql For search
Dim sSql As String
sSql = "SELECT Count(PhoneList.ID) AS IDCnt FROM PhoneList WHERE (PhoneList.ID='" & sId & "')"
'##> Execute command and collect it into a Recordset
Set cmd = New ADODB.Command
cmd.ActiveConnection = cnx
cmd.CommandText = sSql
'ADO library is equipped with a class named Recordset
Set rst = cmd.Execute 'New ADODB.Recordset 'assign memory to the recordset
'Read First RST
rst.MoveFirst
'##> If rst returns a value then ID already exists
If rst.Fields(0) > 0 Then
IdExists = True
End If
'close the recordset
rst.Close
'clear memory
Set rst = Nothing
exitFunction:
Exit Function
errHandler:
'clear memory
Set rst = Nothing
MsgBox "Error " & Err.Number & " :" & Err.Description
End Function
NB: Kindly read any comments preceeded by «'##>» as those are principal changes or explanations you need to understand
Updates:
Here is the File after the updates: https://drive.google.com/open?id=1XqEboSFed_6exDwvBZGOqcZWkN8YaslY
---> Fortunately, you sent me the file as I saw the DbPath was pointing on a wrong cell causing a missing file error. Now all is Fixed and working!
I wish you all the best!
how do I create excel VBA where it will update 1 table while another is going to add data on another table. Below is my code to append a table (tbl_Raw). The new table is tbl_assign with 3 columns. 2 of the column info is located in the code below while the 3rd column is just a time stamp to indicate when it was updated, but placed on another table.
On Error GoTo errHandler
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim i As long, X As long
Dim varr As String
If Me.labelChild.Caption = "Child Ref #" Then
MsgBox "You must enter Child Case.", vbOKOnly Or vbInformation, "Insufficent data"
GoTo CleanUp
End If
Set cnn = New ADODB.Connection
varr = Me.labelChild.Caption
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & "\\10.8.1.62\Chimp Change\Analysis\Database\ChimpDB.accdb"
Set rs = New ADODB.Recordset 'assign memory to the recordset
rs.Open "SELECT Parent_Ref, Child_Ref, Analyst FROM tbl_Raw WHERE Child_Ref = """ & varr & """", ActiveConnection:=cnn, CursorType:=adOpenDynamic, LockType:=adLockOptimistic, Options:=adCmdText
If rs.EOF And rs.BOF Then
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
GoTo CleanUp
End If
With rs
rs!Analyst = Me.Agents.Value
rs.Update
End With
ImportCasesForm
Me.lstCases.RowSource = "CasesList"
MsgBox "Congratulations! The Case has been assigned", vbInformation, "Assign successful"
CleanUp:
If Not rs is Nothing then
rs.close
set rs = nothing
end if
If Not cnn is Nothing then
cnn.close
set cnn = nothing
end if
Exit Sub
errHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Load Cases"
GoTo CleanUp
End Sub
I don't know if I need to do a SUB or just tweak the existing append code to also do add to another table.
Thanks.
After some time and lots of help from stackOverflow users and Christos Samaras Tutorial on [Running Access Queries From Excel Using VBA] (https://myengineeringworld.net/2013/10/running-access-queries-from-excel-vba.html), I got most of what I need in terms of getting data from Access using a parameter.
Here's my problem, I would like to enter the parameter using an InputBox. For some reason, it keeps telling me that the recordset was not created. Then the function exits and nothing happened.
I've tried to use different versions of setting up the strSQL string, but each time I get further away from it working.
Again, the first code does work, but I'm having a hard time implementing something that would ask for a parameter.
'''THIS CODE WORKS'''
Public Function ProjLookup(ProjID As String) As Boolean
Dim INV_WB As Workbook
Dim ProjSet As Worksheet
Dim CovPage As Worksheet
Dim DataConnect As Object
Dim RecordSet As Object
Dim strTable As String
Dim strSQL As String
Dim i As Integer
Set INV_WB = ActiveWorkbook
Set ProjSet = INV_WB.Worksheets("ProjectSetup")
Set CovPage = INV_WB.Worksheets("CoverPage")
'---> Establish connection
On Error Resume Next
Set DataConnect = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created", vbCritical, "Connection Error"
Exit Function
End If
On Error GoTo 0
'---> Open connection with Project Details database
DataConnect.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=C:\Users\CTR90947\OneDrive - PAE\Database\Project Details.accdb"
'---->I would like to enter 601130 into an InputBox
strSQL = "SELECT [Level_1_ProjID], [Legacy_Lvl1_Proj], [ProjectID], [Legacy_ProjID], [Level_Number], [Project_Name] FROM qr_Map_ProjSetupDetail WHERE [Level_1_ProjID] = '601130'"
'Create Recordset
Set RecordSet = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
Set RecordSet = Nothing
Set DataConnect = Nothing
MsgBox "Recordset was not created", vbCritical, "Recordset Error"
End If
RecordSet.CursorLocation = 3
RecordSet.CursorType = 1
'Open Recordset using strSQL
RecordSet.Open strSQL, DataConnect
If RecordSet.EOF And RecordSet.BOF Then
RecordSet.Close
DataConnect.Close
Set RecordSet = Nothing
Set DataConnect = Nothing
MsgBox "There are no records in the recordset", vbCritical, "No Records Found"
Exit Function
End If
'---> Enter names into columns in ProjectSetup worksheet
For i = 0 To RecordSet.Fields.Count - 1
ProjSet.Cells(5, i + 1) = RecordSet.Fields(i).Name
Next i
'---> Populate ProjectSetup worksheet using recordset results
ProjSet.Range("A6").CopyFromRecordset RecordSet
RecordSet.Close
DataConnect.Close
MsgBox "Project Setup Query complete!"
End Function
'''THIS CODE DOESN'T WORK'''
Public Function ProjLookupWithInputBox(ProjID As String) As Boolean
Dim INV_WB As Workbook
Dim ProjSet As Worksheet
Dim CovPage As Worksheet
Dim LVL1_GLPROD_ID As String
Dim DataConnect As Object
Dim RecordSet As Object
Dim strTable As String
Dim strSQL As String
Dim i As Integer
Set INV_WB = ActiveWorkbook
Set ProjSet = INV_WB.Worksheets("ProjectSetup")
Set CovPage = INV_WB.Worksheets("CoverPage")
On Error Resume Next
Set DataConnect = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created", vbCritical, "Connection Error"
Exit Function
End If
On Error GoTo 0
DataConnect.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=C:\Users\CTR90947\OneDrive - PAE\Database\Project Details.accdb"
LVL1_GLPROD_ID = InputBox(Prompt:="Enter 6 Digit GLPRD Project ID", Title:="Project ID Input Box", Default:="Type Here")
strSQL = "SELECT [Level_1_ProjID], [Legacy_Lvl1_Proj], [ProjectID], [Legacy_ProjID], [Level_Number], [Project_Name] FROM qr_Map_ProjSetupDetail WHERE [Level_1_ProjID] = 'LVL1_GLPROD_ID'"
Set RecordSet = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
Set RecordSet = Nothing
Set DataConnect = Nothing
MsgBox "Recordset was not created", vbCritical, "Recordset Error"
End If
RecordSet.CursorLocation = 3
RecordSet.CursorType = 1
RecordSet.Open strSQL, DataConnect
If RecordSet.EOF And RecordSet.BOF Then
RecordSet.Close
DataConnect.Close
Set RecordSet = Nothing
Set DataConnect = Nothing
MsgBox "There are no records in the recordset", vbCritical, "No Records Found"
Exit Function
End If
For i = 0 To RecordSet.Fields.Count - 1
ProjSet.Cells(5, i + 1) = RecordSet.Fields(i).Name
Next i
ProjSet.Range("A6").CopyFromRecordset RecordSet
RecordSet.Close
DataConnect.Close
MsgBox "Project Setup Query complete!"
End Function
When I walk through the code and watch the progress through the Locals screen, everything seems to work fine until I step through the 'RecordSet.Open strSQL, DataConnect' line. Not sure why no records are returned.
the code that doesnt work has the variable within the string literal - the variable cannot be referenced this way. It has to be
LVL1_GLPROD_ID = InputBox(Prompt:="Enter 6 Digit GLPRD Project ID", Title:="Project ID Input Box", Default:="Type Here")
strSQL = "SELECT [Level_1_ProjID], [Legacy_Lvl1_Proj], [ProjectID], [Legacy_ProjID], [Level_Number], [Project_Name] FROM qr_Map_ProjSetupDetail WHERE [Level_1_ProjID] = '" & LVL1_GLPROD_ID & "'"
More technical nonsense:
the real reason it doesnt work is there is no value in the column "[Level_1_ProjID]" that equals "LVL1_GLPROD_ID"
i also did some light rewrite for you:
Public Function ProjLookupWithInputBox(ProjID As String) As Boolean
Dim INV_WB As Workbook
Dim LVL1_GLPROD_ID As String, strTable As String, strSQL As String
Dim DataConnect As Object, rs As Object 'also naming objects after reserved words is dumb.
Dim i As long 'i dont use integer often, because sometimes you unintentionally get past the upperbound of the data type. Plus int in SQL Server = long in vba
Set INV_WB = ActiveWorkbook
On Error Resume Next 'i hate this
Set DataConnect = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created", vbCritical, "Connection Error"
Exit Function
End If
On Error GoTo 0 ' i also hate this
DataConnect.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=C:\Users\CTR90947\OneDrive - PAE\Database\Project Details.accdb"
LVL1_GLPROD_ID = InputBox(Prompt:="Enter 6 Digit GLPRD Project ID", Title:="Project ID Input Box", Default:="Type Here")
strSQL = "SELECT [Level_1_ProjID], [Legacy_Lvl1_Proj], [ProjectID], [Legacy_ProjID], [Level_Number], [Project_Name] FROM qr_Map_ProjSetupDetail WHERE [Level_1_ProjID] ='" & LVL1_GLPROD_ID & "';"
Set rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
Set rs = Nothing
Set DataConnect = Nothing
MsgBox "rs was not created", vbCritical, "rs Error"
End If
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open strSQL, DataConnect
If rs.EOF And rs.BOF Then
rs.Close
DataConnect.Close
Set rs = Nothing
Set DataConnect = Nothing
MsgBox "There are no records in the recordset", vbCritical, "No Records Found"
Exit Function
End If
For i = 0 To rs.Fields.Count - 1
INV_WB.Worksheets("ProjectSetup").Cells(5, i + 1) = rs.Fields(i).Name
Next i
INV_WB.Worksheets("ProjectSetup").Range("A6").CopyFromRecordSet rs
rs.Close
DataConnect.Close
MsgBox "Project Setup Query complete!"
End Function
So basically I would like to be able to send date from excel to access, run some queries, and send the results back to excel, and do this all from excel VBA.
I would like to send my data, which is in an excel worksheet with sheet name "Enrollment Data Aggregate" to an access database H:\My file extension\Nameofdatabase.accdb and save it as a table with the name "Enrollment Data Aggregate".
I already have queries put together that run from the table "Enrollment Data Aggregate", so I think (hope) that I can delete that table, and when I pull in the new one from excel, the queries will still update. Then I would like access to run/update the queries and export them as separate tabs to my excel file.
Ideally, I would then like to continue doing other things in excel VBA. In other words, I'm really hoping that I can control all of this from excel. I have plenty of experience with excel and access, but I've only done about 4 VBA projects that were large like this (I've done lots of small macros) so I'm not super experienced. Any suggestions would be greatly appreciated.
To export data from Excel to Access:
Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=C:\FolderName\DataBaseName.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("A" & r).Value
.Fields("FieldName2") = Range("B" & r).Value
.Fields("FieldNameN") = Range("C" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
To import data from Access to Excel:
Sub ADOImportFromAccessTable(DBFullName As String, _
TableName As String, TargetRange As Range)
' Example: ADOImportFromAccessTable "C:\FolderName\DataBaseName.mdb", _
"TableName", Range("C1")
Dim cn As ADODB.Connection, rs As ADODB.Recordset, intColIndex As Integer
Set TargetRange = TargetRange.Cells(1, 1)
' open the database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
DBFullName & ";"
Set rs = New ADODB.Recordset
With rs
' open the recordset
.Open TableName, cn, adOpenStatic, adLockOptimistic, adCmdTable
' all records
'.Open "SELECT * FROM " & TableName & _
" WHERE [FieldName] = 'MyCriteria'", cn, , , adCmdText
' filter records
RS2WS rs, TargetRange ' write data from the recordset to the worksheet
' ' optional approach for Excel 2000 or later (RS2WS is not necessary)
' For intColIndex = 0 To rs.Fields.Count - 1 ' the field names
' TargetRange.Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
' Next
' TargetRange.Offset(1, 0).CopyFromRecordset rs ' the recordset data
End With
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Running an Access Query from Excel:
Sub CreateAndRunQuery()
'------------------------------------------------------------------------------------------
'This macro opens the Sample.accdb database, creates and runs an SQL query (filtering
'all the customers from Canada). Then, it copies selected fields back in the Excel sheet.
'The code uses late binding, so no reference to external library is required.
'Written By: Christos Samaras
'Date: 05/10/2013
'Last Updated: 29/11/2014
'E-mail: xristos.samaras#gmail.com
'Site: http://www.myengineeringworld.net
'------------------------------------------------------------------------------------------
'Declaring the necessary variables.
Dim con As Object
Dim rs As Object
Dim AccessFile As String
Dim strTable As String
Dim SQL As String
Dim i As Integer
'Disable screen flickering.
Application.ScreenUpdating = False
'Specify the file path of the accdb file. You can also use the full path of the file like:
'AccessFile = "C:\Users\Christos\Desktop\Sample.accdb"
AccessFile = ThisWorkbook.Path & "\" & "Sample.accdb"
'Set the name of the table you want to retrieve the data.
strTable = "Customers"
On Error Resume Next
'Create the ADODB connection object.
Set con = CreateObject("ADODB.connection")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection Error"
Exit Sub
End If
On Error GoTo 0
'Open the connection.
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
'Create the SQL statement to retrieve the data from table.
'Get the necessary information (first name etc.) for all the Canadian customers.
SQL = "SELECT FirstName, LastName, Address, City, Phone FROM " & strTable & " WHERE COUNTRY='Canada'"
On Error Resume Next
'Create the ADODB recordset object.
Set rs = CreateObject("ADODB.Recordset")
'Check if the object was created.
If Err.Number <> 0 Then
'Error! Release the objects and exit.
Set rs = Nothing
Set con = Nothing
'Display an error message to the user.
MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
Exit Sub
End If
On Error GoTo 0
'Set thee cursor location.
rs.CursorLocation = 3 'adUseClient on early binding
rs.CursorType = 1 'adOpenKeyset on early binding
'Open the recordset.
rs.Open SQL, con
'Check if the recordet is empty.
If rs.EOF And rs.BOF Then
'Close the recordet and the connection.
rs.Close
con.Close
'Release the objects.
Set rs = Nothing
Set con = Nothing
'Enable the screen.
Application.ScreenUpdating = True
'In case of an empty recordset display an error.
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
'Copy the recordset headers.
For i = 0 To rs.Fields.Count - 1
Sheets("New Query").Cells(1, i + 1) = rs.Fields(i).Name
Next i
'Write the query values in the sheet.
Sheets("New Query").Range("A2").CopyFromRecordset rs
'Close the recordet and the connection.
rs.Close
con.Close
'Release the objects.
Set rs = Nothing
Set con = Nothing
'Adjust the columns' width.
Sheets("New Query").Columns("A:E").AutoFit
'Enable the screen.
Application.ScreenUpdating = True
'Inform the user that the macro was executed successfully.
MsgBox "The Canadian customers were successfully retrieved from the '" & strTable & "' table!", vbInformation, "Done"
End Sub
You will find more info here.
http://www.myengineeringworld.net/2013/10/running-access-queries-from-excel-vba.html
After some searching I have found a macro to export an Excel sheet as record in a password protected Access database
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath
Dim i As Long
'add error handling
On Error GoTo errHandler:
'Variables for file path and last row of data
dbPath = ("\\serverpath\reporting.accdb")
'Initialise the collection class variable
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath, , "password"
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.Open Source:="table", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
rst.AddNew
For i = 1 To 180
rst(Cells(1, i).Value) = Cells(nextrow, i).Value
Next i
rst.Update
'close the recordset
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"
I get an error "Error 2147217843 The workgroup information file is missing" at cnn.Open
That error message is misleading. The problem is not about a MDW (workgroup information file).
There are 2 types of passwords for Access databases:
passwords associated with individual Access security user accounts
a password which applies to the database itself, and all users must supply that password to open the database
Your password is the second type, but your connection attempt treats it as the first type.
Use the Jet OLEDB:Database Password option in your connection string.
Dim strConnect As String
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
dbPath & ";Jet OLEDB:Database Password='password';"
Debug.Print strConnect
cnn.Open strConnect
You could try passing the info about the workgroup file, though I believe it primarily is for mdb files:
Provider=Microsoft.Jet.OLEDB.12.0;Data Source=D:\Test\Test.accdb;User ID=Admin;Jet OLEDB:System database=D:\Test\System.mdw;