VBA to get data to excel from access

[aryanaveen]

Hi All,

Please help me with the below, I have a excel VBA code which will open access database and filter based on SQL criteria and copy filtered data and paste it in excel file.

Option Explicit

Sub CreateAndRunQuery()

Dim con As Object
Dim rs As Object
Dim AccessFile As String
Dim strTable As String
Dim SQL As String
Dim i As Integer

Application.ScreenUpdating = False
AccessFile = "C:\Honnesh\Data dump.accdb"
strTable = "Table1"
On Error Resume Next
Set con = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection Error"
Exit Sub
End If
On Error GoTo 0
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
SQL = "SELECT Client ID" & strTable & " WHERE Client id='ABC'"
On Error Resume Next
Set rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
Set rs = Nothing
Set con = Nothing
MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
Exit Sub
End If
On Error GoTo 0
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open SQL, con -------- I AM GETTING ERROR in this line
If rs.EOF And rs.BOF Then
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
For i = 0 To rs.Fields.Count - 1
Sheets("New Query").Cells(1, i + 1) = rs.Fields(i).Name
Next i
Sheets("New Query").Range("A2").CopyFromRecordset rs
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Sheets("New Query").Columns("A:E").AutoFit
Application.ScreenUpdating = True
MsgBox "Done"

End Sub
--------------------------------------------------------------------------------

But I am betting run time error

RUn time error : Syntax error(missing operator) in query expression 'ClientIDTable1 WHERE Client ID='ABC".


Please help

 

[JHB]

You're a missing a space after "ID", and also [] around Client ID, don't use spaces or special characters in field names:
And you haven't the "FROM" either.

SQL = "SELECT [B][COLOR=Red][[/COLOR][/B]Client ID[B][COLOR=Red]] FROM "[/COLOR][/B] & strTable & " WHERE [B][COLOR=Red][[/COLOR][/B]Client ID[B][COLOR=Red]][/COLOR][/B]='ABC'"

 

[aryanaveen]

Thank you JHB, its working

 

[JHB]

Good you got it working.

 

[aryanaveen]

Hi JHB

One more help

Dim con As Object
Dim rs As Object
Dim AccessFile As String
Dim strTable As String
Dim SQL As String
Dim i As Integer
Dim a As Variant

a = Range("F3").Value
SQL = "SELECT [Invoice Number], [Invoice Date], [Invoice Amount] FROM " & strTable & " WHERE [Eng Id] = " & a & " "


A is defined as value in Range F3 which is an engagement number (12345678)

Now how can I use the value in SQL WHERE

 

[JHB]

Have you tried ..... strTable & " WHERE [Eng Id] = " & a ?
If yes, what is the problem, some error number/error description?

 

[aryanaveen]

Hi JHB

Below is the code I modified and its working, Thanks for your help.

I have one more problem, The macro is taking too much time in getting connection, is their a way to make it faster

Option Explicit

Function CreateAndRunQuery()


Dim con As Object
Dim rs As Object
Dim AccessFile As String
Dim strTable As String
Dim SQL As String
Dim i As Integer
Dim a As Range
Set a = Range("F3")

Sheets("Invoice History").Select
Application.ScreenUpdating = False
AccessFile = "Server path\Invoice dump.accdb"
Application.Wait (Now + TimeValue("0:00:02"))


strTable = "Table1"
On Error Resume Next
Set con = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection Error"
Exit Function
End If
On Error GoTo 0
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile


SQL = "SELECT [Invoice Number], [Invoice Date], [Invoice Amount] FROM " & strTable & " WHERE [Eng Id] = '" & a & "'"

On Error Resume Next
Set rs = CreateObject("ADODB.Recordset")
If Err.Number <> 0 Then
Set rs = Nothing
Set con = Nothing
'MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
Exit Function
End If
On Error GoTo 0
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open SQL, con - ------------ AT THIS STEP MACRO IS TAKING TOO MUCH TIME TO GET CONNECTION, Is their any way to make it faster
If rs.EOF And rs.BOF Then
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Application.ScreenUpdating = True
'MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Function
End If
For i = 0 To rs.Fields.Count - 1
Sheets("Invoice History").Cells(10, i + 2) = rs.Fields(i).Name
Next i
Sheets("Invoice History").Range("B11").CopyFromRecordset rs

rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Application.ScreenUpdating = True


'MsgBox "Done"

End Function

 

[aryanaveen]

Any help