VBA to insert many records into access DB fast - sql

OK so I have a spreadsheet that produces a reasonably large amount of records (~3500)
I have the following script that inserts them into my access db:
Sub putinDB()
Dim Cn As ADODB.Connection, Rs As ADODB.Recordset
Dim MyConn, sSQL As String
Dim Rw As Long, c As Long
Dim MyField, Result
Dim x As Integer
Dim accName As String, AccNum As String, sector As String, holding As String, holdingvalue As Double, holdingdate As Date
theend = lastRow("Holdings", 1) - 1
'Set source
MyConn = "S:\Docs\Harry\Engine Client\Engine3.accdb"
'Create query
Set r = Sheets("Holdings").Range("a2")
x = 0
Do
Application.StatusBar = "Inserting record " & x + 1 & " of " & theend
accName = r.Offset(x, 0)
AccNum = r.Offset(x, 4)
sector = r.Offset(x, 2)
holding = r.Offset(x, 1)
holdingvalue = r.Offset(x, 3)
holdingdate = r.Offset(x, 5)
sSQL = "INSERT INTO Holdings (AccName, AccNum, Sector, Holding, HoldingValue, HoldingDate)"
sSQL = sSQL & " VALUES ('" & Replace(accName, "'", "''") & "', '" & AccNum & "', '" & sector & "', '" & Replace(holding, "'", "''") & "', '" & holdingvalue & "', #" & holdingdate & "#)"
Debug.Print (sSQL)
'Create RecordSet
Set Cn = New ADODB.Connection
With Cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.CursorLocation = adUseClient
.Open MyConn
Set Rs = .Execute(sSQL)
End With
x = x + 1
Loop While r.Offset(x, 0) <> "" Or x < 15
Application.StatusBar = False
End Sub
The trouble is, is that it loops through each record one-by-one, rebuilds and executes the query each time which results in very slow execution (about 2-3 records per second on my PC)
Is there a way to have vba insert the whole range into the DB in one go without having to loop through?
Thanks

The answer you have provided should improve things slightly as you only need open the connection once, but the code is still inefficient. You really only want to write to your recordset once with all the data rather than like this. I always prefer working from the Access side to pull info from Excel as oppose to pushing into Access from Excel but I believe we can use either for this scenario.
In this case your better to use DAO over ADO and work with a Transacation, essentially you still loop over the recordset but the actual act of writing the data does not happen until you Commit at the end so it's much faster.
This is a very basic example from the Access side for you to try:
Private Sub TestTrans()
Dim wksp As DAO.Workspace
Dim rs As DAO.Recordset
Set wksp = DBEngine.Workspaces(0) 'The current database
wksp.BeginTrans 'Start the transaction buffer
Set rs = CurrentDb.OpenRecordset("Table1", dbOpenDynaset)
Do 'Begin your loop here
With rs
.AddNew
!Field = "Sample Data"
.Update
End With
Loop 'End it here
wksp.CommitTrans 'Commit the transaction to dataset
End Sub

OK, silly me. After a bit of tinkering it turns out that putting the
Set Cn = New ADODB.Connection
With Cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.CursorLocation = adUseClient
.Open MyConn
End With
bit outside the loop makes it far quicker.

Related

How to Transfer VBA UserForm Data To Access Database?

I have created a user form in excel to save my records in a sheets like sheet1.
But after few days working with this UserForm, it is now goes slower, because of heavy data saving in sheet1.
Now I want to save all records to a database and want to keep clean my sheet1.
So I can work on my UserForm easily or without any delay. Also wants updates my record by calling it via serial numbers.
but I don't want to keep any record in my sheet1.
my little code is below: -
Sub cmdAdd_Click()
On Error GoTo ErrOccured
BlnVal = 0
If BlnVal = 0 Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim txtId, txtName, GenderValue, txtLocation, txtCNum, txtEAddr, txtRemarks
Dim iCnt As Integer
iCnt = fn_LastRow(Sheets("Data")) + 1
If frmData.obMale = True Then
GenderValue = "Male"
Else
GenderValue = "Female"
End If
With Sheets("Data")
.Cells(iCnt, 1) = iCnt - 1
.Cells(iCnt, 2) = frmData.txtName
.Cells(iCnt, 3) = GenderValue
.Cells(iCnt, 4) = frmData.txtLocation.Value
.Cells(iCnt, 5) = frmData.txtEAddr
.Cells(iCnt, 6) = frmData.txtCNum
.Cells(iCnt, 7) = frmData.txtRemarks
.Columns("A:G").Columns.AutoFit
.Range("A1:G1").Font.Bold = True
.Range("A1:G1").LineStyle = xlDash
End If
End With
Dim IdVal As Integer
IdVal = fn_LastRow(Sheets("Data"))
frmData.txtId = IdVal
ErrOccured:
'TurnOn screen updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I will always be grateful to you.
Then, please try the next way. I will try creating of the necessary DB, table and fields using Excel VBA, too:
Copy the next piece of code which will create an empty DB, on the path you want:
Sub CreateEmptyDB()
Dim strPath As String, objAccess As Object
strPath = "C:\Your path\testDB"
Set objAccess = CreateObject("Access.Application")
Call objAccess.NewCurrentDatabase(strPath)
objAccess.Quit
End Sub
Programatically create the necessary table with its fields (`Start Date' added only to see how this type of data is handled...):
Sub createTableFields()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim Catalog As Object, cn As ADODB.Connection
Dim dbPath As String, scn As String, strTable As String
dbPath = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
Set Catalog = CreateObject("ADOX.Catalog")
Set cn = New ADODB.Connection
With cn
.Open scn
.Execute "CREATE TABLE " & strTable & " ([Name] text(255) WITH " & _
"Compression, " & "[Gender] text(255) WITH Compression, " & _
"[Location] text(255) WITH Compression, " & _
"[Address] text(255) WITH Compression, " & _
"[Number] number, " & _
"[Remarks] text(255) WITH Compression, " & _
"[Start Date] datetime)"
End With
cn.Close
End Sub
Add records to the newly created DB/Table:
Sub FillDataInDB()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim AccessDB As String, strTable As String, sql As String
Dim con As ADODB.Connection, rs As ADODB.Recordset, lastNo As Long
AccessDB = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
Set con = CreateObject("ADODB.connection")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB
sql = "SELECT * FROM " & strTable
Set rs = CreateObject("ADODB.Recordset")
rs.CursorType = 1 'adOpenKeyset on early binding
rs.LockType = 3 'adLockOptimistic on early binding
rs.Open sql, con
If rs.RecordCount = 0 Then
lastNo = 0 'when no records in the table
Else
rs.MoveLast: lastNo = rs("Number") 'the last recorded value
End If
rs.AddNew
rs("Name") = "Test name" 'frmData.txtName
rs("Gender") = "Test gender" 'GenderValue
rs("Location") = "Test Location" 'frmData.txtLocation.Value
rs("Address") = "Test Address" 'frmData.txtEAddr
rs("Number") = IIf(lastNo = 0, 100, lastNo + 1) 'auto incrementing against the last value
'but starting from 100
'you can use frmData.txtCNum
rs("Remarks") = "Remarkable table..." 'frmData.txtRemarks
rs("Start Date") = Date
rs.Update
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing
End Sub
Run the first two pieces of code in consecutive order (only once) and then start playing with the third one...
You can read the newly created DB Table (returning in an Excel sheet) in this way:
Sub ADO_Connection_ReadTable()
Dim conn As New Connection, rec As New Recordset, sh As Worksheet
Dim AccessDB As String, connString, query As String, strTable As String
AccessDB = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
Set sh = ActiveSheet 'use here the sheet you want
connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB
conn.Open connString
query = "SELECT * from " & strTable & ";"
rec.Open query, conn
'return in the sheet
sh.cells.ClearContents
'getting data from the recordset if any and returning some in columns A:B:
If (rec.RecordCount <> 0) Then
Do While Not rec.EOF
With sh.Range("A" & sh.cells(Rows.count, 1).End(xlUp).row).Offset(1, 0)
.Value2 = rec.fields(0).Value
.Offset(0, 1).Value2 = rec.fields(3)
End With
rec.MoveNext
Loop
End If
rec.Close: conn.Close
End Sub
You can use a query to return specific data according to a specific table field. You can find plenty of examples on the internet.
I tried also showing how to handle an automate recording for the 'Number' field. Of course, if you are able to keep track of it in a different way, you can record it as you need/wont.
Please, test the above code(s) and send some feedback. You can use the DB path as a Private constant at the module level and much other ways to optimize the code. It is just a minimum workable solution only showing the way... :)

Error Updating ACCESS from ADODB Command / Recordset

First off, I truly apologize if someone promptly points me to a post in which this question was answered. I'm not great at sifting through the boards, but have been searching for about a week. Many threads are similar to my problem, but none exactly mirror what I'm trying to do or the problem I'm having. The closest I've found was posted here. The solution reached there did not solve my issue.
I am trying to update records in an ACCESS 2007 database from an update Excel worksheet using VBA. I have accomplished getting information from ACCESS into Excel, and from Excel into my recordset. Now, I need to update ACCESS with the populated recordset.
Public Sub Read_Spreadsheet()
Dim strSql As String, target_fields As String
Dim fuel_table As String, new_values As String
Dim roww As Integer, coll As Integer
Dim i As Integer, n As Integer, mbrs(32) As Integer
Call Load_Globals
' Configure ADODB connection, command, recordset objects
With cn1
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Data Source = " & Src_WB_nm & "; " & _
"Extended Properties='Excel 8.0;HDR=Yes;IMEX=1'"
.Open
End With
Set cmd1.ActiveConnection = cn1
cmd1.CommandType = adCmdText
cmd1.CommandText = "SELECT * FROM [" & Src_WS_nm & "$]"
With rs1
.CursorLocation = adUseClient ' used 3 previously
.CursorType = adOpenDynamic ' used 1 previously
.LockType = adLockOptimistic
.Open cmd1
End With
Debug.Print "Excel Connection established; recordset created."
Debug.Print "Fields: " & rs1.Fields.count
Debug.Print rs1.Fields(0).name
Debug.Print rs1.Fields(1).name
'--------------------------------------------------------------------------
With cn2
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source = " & Dest_DB
.Open
End With
With rs2
.CursorLocation = adUseClient ' used 3 previously
.CursorType = adOpenDynamic ' used 1 previously
.LockType = adLockOptimistic
End With
Debug.Print "Access connection established."
'--------------------------------------------------------------------------
' NOTE to S.O. readers, Two nested loops are commented out below
' These will eventually loop through an uncertain number of fields
' (~10) and records (~2000) to make all the SQL updates. For debugging,
' I'm just trying to get 1 pass to be successful.
'
' For n = 1 To rs1.RecordCount
' strSql = "SELECT ID, FSERIAL FROM TESTTABLE WHERE ID = 1"
strSql = ""
i = 1
' For i = 1 To rs1.Fields.count - 1
If i <> 1 Then strSql = strSql & ", "
strSql = strSql & " SET [" & rs1.Fields(i).name & "] = " & Chr(39) & rs1.Fields(i).Value & Chr(39)
' Next i
strSql = "UPDATE " & Dest_Table & strSql & " WHERE [ID] = " & rs1.Fields(0).Value
strSql = "UPDATE TESTTABLE SET BATCH = 'B' WHERE ID = 11"
Debug.Print strSql
Set cmd2 = New ADODB.Command
With cmd2
.ActiveConnection = cn2
.CommandType = adCmdText
.CommandText = strSql
.Execute , , adCmdText + adExecuteNoRecords
End With
' CP.Cells(27 + n, 4) = rs1(0)
' CP.Cells(27 + n, 5) = rs1(1)
rs1.MoveNext
Set cmd2 = Nothing
' Next n
' cmd2.CommandText = "SELECT ID, FSERIAL FROM TESTTABLE WHERE ID = 1"
' cmd2.CommandText = "UPDATE TESTTABLE SET BATCH = B WHERE ID = 1"
' Debug.Print cmd2.CommandText
' rs2.Open cmd2
' CP.Cells(28, 4).CopyFromRecordset rs2
Call Close_Connections
End Sub
Both Access & Excel are 2007, and I'm in Windows 7, 32 Bit OS. I'm using the following VBA references: MS ADO Ext. 6.0 for DDL and Security, MS ActiveX Data Ojects Recordset 6.0 Lib, MS ActiveX Objeects 6.1 Lib, MS Access 12.0 Object Lib, OLE Automation. (sorry, I cannot post images yet)
Everything works fine up until the cmd2.execute command (That is the line highlighted by the debugger). If I replace the SQL query with a simple static SELECT and dump it into rs2, it works fine. It's when I try to update only that I get the problem.
The debug.print strSQL command yields"'UPDATE TESTTABLE SET BATCH = 'B' WHERE ID = 11"
I've also tried "UPDATE TESTTABLE SET [BATCH] = 'B' WHERE [ID] = 11" and other permutations, with no success.
The error is : "Run-time error '-2147217904 (80040e10)': No value given for one or more required parameters."
Thank you for your help! I appreciate it very much, and will be sure to rank/flag the solution.
,Mike Shanahan
Your query is ill-formed. I think what you want is:
For i = 1 To rs1.Fields.count - 1
if i<>1 Then strsql = strsql & ", "
strSql = strSql & "[" & rs1.Fields(i).name & "] = " & rs1.Fields(i).Value
Next i
strsql = "UPDATE " & Dest_Table & " SET " & strSql & " WHERE [ID] = " & rs1.Fields(0).Value
Still, this supposes all values are numeric. You'll need to still work it out so that values corresponding to strings are enclosed with single quotes. For example, your test query should be:
.CommandText = "UPDATE TESTTABLE SET BATCH = 'B' WHERE ID = 1"
' ^^^
As suggested in comments, a simple Debug.Print strsql is very helful to debug your queries.

MS Access - VBA Do while TxtBox is Not Empty

Public Sub Ohno()
Dim stsql As String, results As String
Dim rs As Object, Db As Object, con As Object
Dim num As Integer
Dim start As Object
Set Db = CurrentDb()
Set con = Application.CurrentProject.Connection
Set rs = CreateObject("ADODB.Recordset")
num = 1
For num = 1 To 2
Do While IsEmpty(Forms("setup").Controls("TxtBoxEntry" & num)) = False
Set start = Forms("setup").Controls("TxtBoxEntry" & num)
stsql = "SELECT [Crosswalk].[Oracle GL Acct] FROM Crosswalk WHERE [Crosswalk].[Legacy GL Acct]= '" & start & "' "
rs.Open stsql, con
results = rs(0).Value
Forms("setup").Controls("TxtBoxRslt" & num).Value = results
Loop
Next
Set con = Nothing
Set rs = Nothing
I keep getting: Operation isn't allow while Object is Open - click me
the code does work for the first txtbox and stops to give me the above error. Am I setting up myself for failure on this one?
You need to close the recordset after using it. Try adding rs.Close:
Set start = Forms("setup").Controls("TxtBoxEntry" & num)
stsql = "SELECT [Crosswalk].[Oracle GL Acct]
FROM Crosswalk WHERE [Crosswalk].[Legacy GL Acct]= '" & start & "' "
rs.Open stsql, con
results = rs(0).Value
Forms("setup").Controls("TxtBoxRslt" & num).Value = results
rs.Close -- Add this here

Fill Listbox with Results of SQL Query

Alright, I might be way off if what I've tried, but here goes. I am trying to execute a SQL query to return some records and then populate a listbox. Essentially, I want every record to display in a separate line. I have this in a separate module referencing the main form. I have heard some things about filling a datatable with the SQL results and then linking the listbox to that as well, but I'm not 100% sure what to do there either. I've just been trying to manually update the listbox with each result, but it doesn't seem to like it. I am using a recordset instead of a datatable, but like I said, it's because I'm unsure of how to use a datatable (haven't done it before but I am willing to learn)
Public Sub addCases()
'Uses windows login credentials to determine and return CSP's Manager's Name
'C
Dim i As Integer
Dim intX As Integer
Dim c As ADODB.Connection
Dim r As ADODB.Recordset
Dim strSQL As String, strManager As String
Set c = New ADODB.Connection
c.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=Commit Tracker.accdb; Persist Security Info=False;"
strSQL = "SELECT "
strSQL = strSQL & "* "
strSQL = strSQL & "FROM "
strSQL = strSQL & "CommitTrk "
strSQL = strSQL & "WHERE "
strSQL = strSQL & "EMP_ID = '" & Username() & "'"
Set r = c.Execute(strSQL)
If r.EOF = False Then
intX = 0
vararray = r.GetRows()
For i = LBound(vararray) To UBound(vararray)
With frmCommitViewer.lstCases
.AddItem
.List(intX, 0) = r.Index(i)
End With
intX = intX + 1
Next i
End If
r.Close
c.Close
Set r = Nothing
Set c = Nothing
End Sub
I figured it out. Instead of the stupid array conversion, I'm still using the recordset directly.
If r.EOF = False Then
With frmCommitViewer.lstCases
.Clear
Do
.AddItem r![CASE_ID_NBR]
r.MoveNext
Loop Until r.EOF
End With
End If
Super simple. Thanks to http://www.fontstuff.com/vba/vbatut10pfv.htm.

Sql query taking values from the column in the excelsheet using VBA(macro)

I need to use sql query using VBA. My input values for the query is from the Column in the excel sheet.I need to take all the values present in the column and it should be passed as input to the query to sqlserver. But i could'nt get the answer. I am getting type mismatch as error. could any one help me out. Thanks in advance
for example in J column contains J1=25, j2=26, ....so on
stSQL = "SELECT * FROM prod..status where state in"
stSQL = stSQL & wsSheet.Range("J:J").Value
My full code is below
Sub Add_Results_Of_ADO_Recordset()
'This was set up using Microsoft ActiveX Data Components version 2.8
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim stSQL As Variant
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnStart As Range
Const stADO As String = "Provider=SQLOLEDB.1;Integrated Security=SSPI;" & _
"Persist Security Info=False;" & _
"Initial Catalog=prod;" & _
"Data Source=777777777V009D\YTR_MAIN4_T"
'where BI is SQL Database & AURDWDEV01 is SQL Server
Set wbBook = ActiveWorkbook
Set wsSheet = wbBook.Worksheets("sheet1")
With wsSheet
Set rnStart = .Range("A2")
End With
' My SQL Query
stSQL = "SELECT * FROM prod..status where state in"
stSQL = stSQL + wsSheet.Range("J:J").Value
Set cnt = New ADODB.Connection
With cnt
.CursorLocation = adUseClient
.Open stADO
.CommandTimeout = 0
Set rst = .Execute(stSQL)
End With
'Here we add the Recordset to the sheet from A1
rnStart.CopyFromRecordset rst
'Cleaning up.
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
End Sub
change to
stSQL = stSQL + " ('" + Replace(wsSheet.range("J:J").Value, "'", "") + ")"
but sql IN statement is usually used like this
state IN (25,26,28)
But if you are only using one integer value you might want to go this way.
stSQL = "SELECT * FROM prod..status where state = "
stSQL = Val(wsSheet.range("J:J").Value)
There is though one thing that is dangerous in using a in statement.
If your In part of the statement is very long, it will become slow and then with even larger in statements crash altogeather.
The solution for that kind of situation is creating a temp table with the in values and do where in (temp table) or a inner join based on the temp table
There is no space after your "in" in your stSQL variable. So if your cell contains the value "TEST", stSQL will be
SELECT * FROM prod..status where state inTEST
I used for loop and mid command to convert the values in the column to a single variable. Below is the code i used to perform the function which i required
' Getting the last row
With wsSheet
lastrow1 = .Range("J" & .Rows.Count).End(xlUp).Row
End With
' Appending the values to a single variable
For i = 1 To lastrow
s1 = s1 & "'" & Val(wsSheet.Cells(i, 10)) & "'" & ","
Next
' Variable which could be used in IN command
If lastrow > 0 Then
s1 = Mid(s1, 1, Len(s1) - 1)
s1 = "(" & s1 & ")"
Else
Exit Sub
End If