I've created below Excel function which connects to an access database with ADODB (approx 10k lines).
It generally works but there are two main issues:
It is unreliable: often it returns 0 while the result should be different
It is definitely slow
Any suggestion on how to improve?
Public Function TotaleSQL(Cat As String, SubCat As String, Anno As Integer) As Long
On Error Resume Next
Dim cn As Object, rs As Object, output As String, sql As String
Dim src As String
Dim Total As Long
Dim CatLong As String
src = "Z:\Report.accdb"
'---Connecting to the Data Source---
Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.connectionstring = "Data Source=" & src & ";Persist Security Info=False"
.Open
End With
'---Run the SQL SELECT Query---
CatLong = "'" & Cat & ":" & SubCat & "'"
sql = "SELECT Report.Withdrawal, Report.Deposit, Report.Category, Report.Date FROM Report WHERE (((Report.Category)=" & CatLong & ") AND ((Year([date]))=" & Anno & "));"
'sql = "SELECT * FROM [Sheet1$]"
Set rs = cn.Execute(sql)
Total = 0
Do
Total = Total + Val(rs(1) & "") - Val(rs(0) & "")
rs.Movenext
Loop Until rs.EOF
'---Clean up---
rs.Close
cn.Close
Set cn = Nothing
Set rs = Nothing
TotaleSQL = Total
End Function
If Cat, SubCat or Anno are user inputs it is more secure to use parameters in your query. For example
Public Function TotaleSQL(Cat As String, SubCat As String, Anno As Integer)
Const DATABASE = "Z:\Report.accdb"
Const TABLE_NAME = "Report"
Const SQL = " SELECT SUM(iif(Deposit is null,0,Deposit) " & _
" - iif(Withdrawal is null,0,Withdrawal)) " & _
" FROM " & TABLE_NAME & _
" WHERE Category = ? " & _
" AND YEAR(ddate)= ? "
Dim cn As Object, cmd As Object, rs As Object
'---Connecting to the Data Source---
Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.connectionstring = "Data Source=" & DATABASE & ";Persist Security Info=False"
.Open
End With
' create command
Set cmd = CreateObject("ADODB.Command")
With cmd
.ActiveConnection = cn
.CommandText = SQL
.CommandType = 1 'adCmdText
.Parameters.Append .CreateParameter("P1", 200, 1, 50) ' 1=adParamInput 200=adVarChar
.Parameters.Append .CreateParameter("P2", 3, 1) ' 3=adInteger
End With
' execute with parameters
With cmd
.Parameters(0).Value = Cat & ":" & SubCat
.Parameters(1).Value = Anno
Set rs = .Execute
End With
TotaleSQL = rs(0)
rs.Close
cn.Close
Set cn = Nothing
Set rs = Nothing
Set cmd = Nothing
End Function
Sub test()
Debug.Print TotaleSQL("Cat", "SubCat", 2020)
End Sub
Related
Can we use SQL command to delete multiple records in a big excel file in excel vba.
Try it and see if you get
Option Explicit
Sub TestDelete()
Dim con As ADODB.Connection, cmd As ADODB.Command
Dim sCon As String, n As Long
sCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties='Excel 12.0 Macro;HDR=YES';"
' sheet1
With Sheet1
.Cells.Clear
.Cells(1, 1) = "A"
.Cells(1, 2) = "B"
For n = 2 To 20
.Cells(n, 1) = n
.Cells(n, 2) = 0
Next
End With
' connect
Set con = New ADODB.Connection
con.Open sCon
' command
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = con
.CommandType = adCmdText
End With
' select
cmd.CommandText = "SELECT [A] FROM [Sheet1$]"
MsgBox cmd.Execute(n).GetString, vbInformation, cmd.CommandText
' update
cmd.CommandText = "UPDATE [Sheet1$] SET [B]=[A]+10"
cmd.Execute n
MsgBox n & " records updated", vbInformation, cmd.CommandText
' delete
cmd.CommandText = "DELETE FROM [Sheet1$] WHERE [B] > 20"
On Error Resume Next
cmd.Execute n
If Err.Number <> 0 Then
MsgBox Err.Description, vbInformation, cmd.CommandText
Else
MsgBox n & " records deleted", vbInformation, cmd.CommandText
End If
End Sub
I am unable to execute a simple sql statement. - sorry I am sure this is simple and I am missing something small. Error says missing the object.
dbPath = "C:\Users\User\Documents\test0419.accdb"
tblName = "Wait_Data_Table"
strcon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & dbPath & "';"
conn.Open strcon
Set wrkSpaceNew = DBEngine.CreateWorkspace("Check", "admin", "", dbUseJet)
rcdDetail = ("SELECT order.ord_id, order.job_id, order.bc_desc, order.ord_amount, order.ord_diff FROM Order")
Set rs = DBEngine.BeginTrans(rcdDetail)
You can use either DAO or ADODB, not normally both. See difference-between-ado-and-dao
Option Explicit
Sub UseDAO()
Const SQL = " SELECT order.ord_id, order.job_id, order.bc_desc, " & _
" order.ord_amount, order.ord_diff " & _
" FROM [Order]"
Const dbpath = "C:\Users\User\Documents\test0419.accdb"
Dim wkspace As workspace, db As DAO.Database, rs As DAO.Recordset
Set wkspace = DBEngine.CreateWorkspace("Check", "admin", "", dbUseJet)
Set db = wkspace.OpenDatabase(dbpath)
Set rs = db.OpenRecordset(SQL)
Sheet1.Range("A1").CopyFromRecordset rs
db.Close
Set db = Nothing
wkspace.Close
Set wkspace = Nothing
MsgBox "Results on sheet " & Sheet1.Name, vbInformation, "DAO"
End Sub
Sub UseADODB()
Const SQL = " SELECT order.ord_id, order.job_id, order.bc_desc, " & _
" order.ord_amount, order.ord_diff " & _
" FROM [Order]"
Const dbpath = "C:\Users\User\Documents\test0419.accdb"
Dim strConn As String, conn As ADODB.Connection, rs As ADODB.Recordset
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & dbpath & "';"
Set conn = New ADODB.Connection
conn.Open strConn
Set rs = conn.Execute(SQL)
Sheet1.Range("A1").CopyFromRecordset rs
conn.Close
MsgBox "Results on sheet " & Sheet1.Name, vbInformation, "ADODB"
End Sub
Don't forget to add Activex Data Object in Reference Section
Dim baglanti As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sunucu, veritabani, id, sifre, sorgu As String
sunucu = "DESKTOP-GF32DLC\SQLEXPRESS"
veritabani = "AdventureWorks2014"
id = ""
sifre = ""
sorgu = "SELECT * FROM [HumanResources].[Department] Where [GroupName]='Manufacturing'"
baglanti.Open "Driver={SQL SERVER};Server=" & sunucu & ";Database=" & veritabani & _
";Uid=" & id & ";Pwd=" & sifre & ";"
rs.Open sorgu, baglanti, adOpenStatic
With Range("A1:AA1000")
.ClearContents
.CopyFromRecordset rs
End With
rs.Close
baglanti.Close
This way you can make a healthy sql connection.
I used to use it to connect sql in the past
I am trying to load data from an Excel file in a specific sheet into an ADODB.RecordSet via a VBA macro by using SQL SELECT command.
There are several columns on the Excel sheet, and I don't need all of them.
For example:
col.A = Surname, col.B = Name, col.C = IDPerson, [....columns that are not needed], Col.N = Boss
The purpose would be to get a recordset of aggregated data for:
col.C = IDPerson, col.N = Boss.
The fields highlighted in the image below.
I would like to have a RecordSet with the aggregated (non-repeating) data of the columns highlighted in yellow.
Obviously, this problem could also be solved by loading a matrix, but, in this case I would have to build a loading algorithm to "clean" any repetitions in the data and then later I would have to provide a search function with some loops.
So I thought that if I could load all the data I need by reading the WorkSheet as if it were a data table and then make a query on it to extract the data that I need and load everything in an ADODB.RecordSet would be much more efficient also for searching for data (filter data for example).
Below I report my code that loads all the data of my sheet:
Public Sub LoadRecordSet(ByVal LastRow As Long, ByVal LastCol As Integer)
Dim cnt As ADODB.Connection
Dim rsData As ADODB.Recordset
Dim strSQL As String
Dim strTMP As String
strTMP = Cells(LastRow, LastCol).Address
strTMP = Replace(strTMP, "$", "")
Set cnt = New ADODB.Connection
cnt.Mode = adModeRead
cnt.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
cnt.Open
strSQL = "SELECT * FROM [Sheet1$C2:" & strTMP & "]"
Set rsData = New ADODB.Recordset
With rsData
Set .ActiveConnection = cnt
.Source = strSQL
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
'TODO - Something with rsData for filtering or to research
'GC
If Not rsData Is Nothing Then
If rsData.State <> adStateClosed Then rsData.Close
Set rsData = Nothing
End If
If Not cnt Is Nothing Then
If cnt.State <> adStateClosed Then cnt.Close
Set cnt = Nothing
End If
End Sub
My question is: "What if I just want to load some columns as described above and aggregate them so they don't have repetitions in the data?"
For example if I want to load similar
SELECT [cod.fiscale], responsabile FROM [MySheet$A3:N480] GROUP BY [cod.fiscale], responsabile
It's possible?
Thank you so much.
I improved my code which is now working:
Public Sub CaricaDati()
Dim cnt As ADODB.Connection
Dim rsDati As ADODB.Recordset
Dim strSQL As String
Dim strTMP As String
Dim i As Integer
on Error GoTo Error_Handler
Range("A3").Select
g_BOLTS_UltimaRiga = LasRow
Call LastCol
strTMP = Cells(g_LastRow, g_LastCol).Address
strTMP = Replace(strTMP, "$", "")
Set cnt = New ADODB.Connection
cnt.Mode = adModeRead
cnt.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
cnt.Open
'strSQL = "SELECT * FROM [2$C2:" & strTMP & "]"
strSQL = "SELECT cf, responsabile FROM [2$C2:" & strTMP & "] GROUP BY cf, responsabile"
Set rsDati = New ADODB.Recordset
With rsDati
Set .ActiveConnection = cnt
.Source = strSQL
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
If Not (rsDati.BOF And rsDati.EOF) Then
strTMP = ""
For i = 0 To rsDati.Fields.Count - 1
strTMP = strTMP & rsDati.Fields(i).Name & ";"
Next i
Debug.Print strTMP
strTMP = ""
rsDati.MoveFirst
Do While Not rsDati.EOF
strTMP = ""
For i = 0 To rsDati.Fields.Count - 1
strTMP = strTMP & rsDati.Fields(i).Value & ";"
Next i
Debug.Print strTMP
rsDati.MoveNext
Loop
End If
Uscita:
On Error Resume Next
'GC
If Not rsDati Is Nothing Then
If rsDati.State <> adStateClosed Then rsDati.Close
Set rsDati = Nothing
End If
If Not cnt Is Nothing Then
If cnt.State <> adStateClosed Then cnt.Close
Set cnt = Nothing
End If
Exit Sub
Error_Handler:
On Error GoTo 0
MsgBox Err.Number & " - " & Err.Description, vbOKOnly + vbCritical, "ERRORE IMPREVISTO"
GoTo Uscita
End Sub
I am trying to export a table from Excel to a table in an Access DB, but I keep getting an error "Database or Object is read only". Here is the code in qestion.
dbWB = Application.ActiveWorkbook.FullName
dbWS = Application.ActiveSheet.Name
dsh = "[" & dbWS & "$]"
Set DB = CreateObject("ADODB.Connection")
dbPath = "\\Corpaa.aa.com\CampusHome\IOCADHome02\758673\Projects\Global Analysis Tool\MX Analysis DB\Global Line MX Hub Review DB.accdb"
scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
DB.Open scn
DB.Execute "DELETE * FROM tblNewSchedule;"
SQLInsert = "INSERT INTO tblNewSchedule "
SQLSelect = "SELECT * "
SQLFrom = "FROM [Excel 8.0; HDR=YES; DATABASE= " & dbWB & "]." & dsh & " "
strQry = SQLInsert & SQLSelect & SQLFrom & ";"
DB.Execute strQry
DB.Close
The DELETE qry executes just fine with no errors. The problem is the strQry execution. I believe it is refrencing that the WB is read-only, but I am running the code from the WB. I am running Office 2010. Thank you for your assistance.
so, after continuing my search, I discovered a different approach that worked perfectly. I found it on this here
Here is my new working code. Thanks for the assistance.
dbWB = Application.ActiveWorkbook.FullName
dbWS = Application.ActiveSheet.Name
dsh = "[" & dbWS & "$]"
Set DB = CreateObject("ADODB.Connection")
dbPath = "\\Corpaa.aa.com\CampusHome\IOCADHome02\758673\Projects\Global Analysis Tool\MX Analysis DB\Global Line MX Hub Review DB.accdb"
scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
DB.Open scn
Dim rs As ADODB.Recordset
Dim r As Long
Dim y As Long
y = TWB.Cells(1, 1).End(xlDown).Row
r = TWB.Cells(1, 1).End(xlToRight).Column
DB.Execute "DELETE * FROM tblNewSchedule;"
Set rs = New ADODB.Recordset
rs.Open "tblNewSchedule", DB, adOpenKeyset, adLockOptimistic, adCmdTable
For i = 2 To y
With rs
.AddNew
For j = 1 To r
fName = TWB.Cells(1, j)
fData = TWB.Cells(i, j)
.Fields(fName) = fData
Next j
End With
Next i
DB.Close
How to execute a query in MS Access db from Excel VBA code or macro.
MS-Access query accepts some parameters, that needs to be passed from Excel.
Thanks
Here is one possibility:
Dim cn As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
strFile = "C:\docs\Test.mdb"
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
cn.Open strCon
strSQL = "INSERT INTO ATable (AField) " _
& "VALUES (" & Sheet1.[A1] & ")"
cn.Execute strSQL
cn.Close
Set cn = Nothing
You can also refer in-line in the sql to a dataset from Excel.
EDIT re comments
Using a command:
strSQL = "SELECT * FROM ATable " _
& "WHERE AField = #AField"
With cmd
Set .ActiveConnection = cn
.CommandText = strSQL
.CommandType = 1 'adCmdText
''ADO Datatypes are often very particular
''adSmallInt = 2 ; adParamInput = 1
.Parameters.Append .CreateParameter("#AField", 2, 1, , Sheet1.[A1])
End With
Set rs = cmd.Execute
See also: http://support.microsoft.com/kb/181782
This uses ADODB.
Set m_Connection = New Connection
If Application.Version = "12.0" Then
m_Connection.Provider = "Microsoft.ACE.OLEDB.12.0"
Else
m_Connection.Provider = "Microsoft.Jet.OLEDB.4.0"
End If
m_Connection.Open <full path to Access DB>
If m_Connection.State > 0 Then
Dim rsSource As New Recordset
rsSource.Open strQuery, m_Connection, adOpenForwardOnly, adLockReadOnly
Dim result As Long
Dim rngTarget As Range
rngTarget = ThisWorkbook.Worksheets(m_SheetName).Range("A1")
If Not rsSource.BOF Then
result = rngTarget.CopyFromRecordset(rsSource)
End If
If rsSource.State Then rsSource.Close
Set rsSource = Nothing
End If
So it runs the query and puts it where you like. strQuery is the name of a query in the db or an SQL string.