I am working on a VBA project in Excel as a record management tool. In one case, a record(s) need to be added to 2 tables within the same Access DB with varying field info. I am able to successfully add to the first table (Tours_Items) which can add multiple records by looping through the available rows. However, I cannot get the following records to add to their respective table (Tours_Tours). When the code is executed I get the following error: "Run-time error'438': Object doesn't support this property or method".
The VBA for executing on Tours_Items is just about identical to Tours_Tours outside of the table names and the looping feature that is required for Tours_Items so I am just utterly bamboozled as to why it will not execute correctly when the more complicated one will. The subs run one after the other; Tours_Items and then Tours_Tours. I have even tried just executing Tours_Tours and I still get the same error.
The fields correctly match the Access DB fields (I have triple checked), and even if they did not, VBA would not throw the object error. The Access DB fields are appropriately configured to accept the types of data that are being added to the record.
Code:
Sub DBAddTours_Items()
Dim DBFile, Tbl As String
Dim SQL As String
Dim j, NxtRowItems, NxtItemRw As Integer
Dim con, rs As Object
Dim wsToursTtl As Worksheet
Set wsToursTtl = Worksheets("Tour Subtotal")
'Fill Items to DB
'Connect to the Database
Set con = CreateObject("ADODB.connection")
'Set File and tables
DBFile = ThisWorkbook.path & "\" & "DailyInfo.accdb"
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBFile
'Define
NxtRowItems = WorksheetFunction.CountA(wsToursTtl.Range("B:B"))
NxtItemRw = WorksheetFunction.CountA(Sheets("Tours_Items").Range("A:A")) + 1
'Create the ADODB recordset object.
Set rs = CreateObject("ADODB.Recordset")
'Define Table and SQL
Tbl = "Tours_Items"
SQL = "SELECT * FROM " & Tbl
'Set the necessary recordset properties.
With rs
.CursorType = 1 'adOpenKeyset on early binding
.LockType = 3 'adLockOptimistic on early binding
'Open the recordset.
.Open SQL, con
'Loop through and add all items
For j = 2 To NxtRowItems
.AddNew
.Fields("ItemID") = (j - 3) + NxtItemRw
.Fields("TourID") = wsToursTtl.Cells(j, 1)
.Fields("ItemNum") = wsToursTtl.Cells(j, 2)
.Fields("Admission") = wsToursTtl.Cells(j, 3)
.Fields("Ticket") = wsToursTtl.Cells(j, 4)
.Fields("Premium/BAT") = wsToursTtl.Cells(j, 5)
.Fields("Tour") = wsToursTtl.Cells(j, 6)
.Fields("Price") = wsToursTtl.Cells(j, 7)
.Update
Next j
'Close Recordset
.Close
End With
'Close the connection.
con.Close
'Release Variables
Set rs = Nothing
Set con = Nothing
SQL = ""
Tbl = ""
End Sub
Sub DBAddTours_Tours()
Dim DBFile, Tbl As String
Dim SQL As String
Dim con, rs As Object
Dim wsToursTtl As Worksheet
Set wsToursTtl = Worksheets("Tour Subtotal")
'Fill Tour info Tours_Tours
'Connect to the Database
Set con = CreateObject("ADODB.connection")
'Set File and tables
DBFile = ThisWorkbook.path & "\" & "DailyInfo.accdb"
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBFile
'Create the ADODB recordset object.
Set rs = CreateObject("ADODB.Recordset")
'Define Table and SQL
Tbl = "Tours_Tours"
SQL = "SELECT * FROM " & Tbl
'Set the necessary recordset properties.
With rs
.CursorType = 1 'adOpenKeyset on early binding
.LockType = 3 'adLockOptimistic on early binding
'Open the recordset.
.Open SQL, con
'Add new record to table
.AddNew
.Field("TourID") = wsToursTtl.Range("TourID_Dest").Value
.Field("TourDate") = wsToursTtl.Range("TourDate_Dest").Value
.Field("TourTime") = wsToursTtl.Range("TourTime_Dest").Value
.Field("Premium/Bat/Disc") = Me.PremiumBAT_Lbl.Caption
.Field("TourType") = wsToursTtl.Range("TourType_Dest").Value
.Field("GuestName") = wsToursTtl.Range("GuestName_Dest").Value
.Field("GuestAddress") = wsToursTtl.Range("GuestAddress_Dest").Value
.Field("GuestPhone") = wsToursTtl.Range("GuestPhone_Dest").Value
.Field("GuestEmail") = wsToursTtl.Range("GuestEmail_Dest").Value
.Field("GuestMember") = wsToursTtl.Range("GuestMem_Dest").Value
.Field("TourComments") = wsToursTtl.Range("Comments_Dest").Value
.Field("SaleDate") = wsToursTtl.Range("SaleDate_Dest").Value
.Field("TransactionDetails") = wsToursTtl.Range("Trxn_Dest").Value
.Field("SoldBy") = wsToursTtl.Range("SoldBy_Dest").Value
.Field("PaymentType") = wsToursTtl.Range("PayType_Dest").Value
.Field("BookedNum") = 2
.Field("LastModified") = Now
.Field("ModifiedBy") = Application.UserName
.Update
'Close Recordset
.Close
End With
'Close the connection.
con.Close
'Release Variables
Set rs = Nothing
Set con = Nothing
SQL = ""
Tbl = ""
End Sub
Any help is much appreciated!
The correct collection to access a field is .Fields plural.
So DBAddTours_Items is correct where in your other procedure, DBAddTours_Tours you called upon .Field singular. Which doesn't exist.
Documentation found here: https://learn.microsoft.com/en-us/sql/ado/guide/data/the-fields-collection?view=sql-server-ver15
Related
I am working on a project where I'm using SQL to return records from a database into a listbox using userinput. Things are fine when there's more than one result, the listbox reads properly. However, when there's only one record, it doesn't transpose it like it does with all the others. Multiple Returns Single Return
I've tried to do an "if employeeoutput.recordcount = 1 then don't transpose" type of thing, but that still sends me with the Single Return.
Private Sub cmdSearch_Click()
Stop
'connect to database
'make dynamic code
'profit
'set up DB and Recordset
Dim calldbconn As ADODB.Connection
Dim EmployeeOutput As ADODB.Recordset
Dim EmpData As Variant
'its a special tool we're going to use later
Dim InContactInput As String
Dim FNameInput As String
Dim LNameInput As String
Dim TeamNameInput As String
Dim TeamNumberInput As Integer
Dim SQLString As String
'set it up for a new recordset
Set calldbconn = New ADODB.Connection
Set EmployeeOutput = New ADODB.Recordset
'set the vars
InContactInput = txtInContactNum.Value
FNameInput = txtFirstName.Value
LNameInput = txtLastName.Value
TeamNameInput = cboTeamName.Value
TeamNumberInput = cboTeamName.ListIndex + 1
'---------A bunch of stuff here to build the SQL String----------
'----------------------------------------------------------------
'Time to connect
calldbconn.ConnectionString = StrCallDB
calldbconn.Open
On Error GoTo CloseConnection
With EmployeeOutput
.ActiveConnection = calldbconn
.Source = SQLString
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Open
EmpData = .GetRows
On Error GoTo CloseRecordset
End With
'And now, the list box
With lstResults
.Clear
.List = Application.Transpose(EmpData)
End With
'close and reset
CloseRecordset:
EmployeeOutput.Close
CloseConnection:
calldbconn.Close
Set EmployeeOutput = Nothing
Set calldbconn = Nothing
End Sub
Hi Im making a Excel Form in which my Database is an access.
First I Encode data in Excel then Using Command Button to Post these data.
The code within the Command Button.. first get the Max Number from Access and use that Number to Complete the Data in Excel to be exported to Access. The Problem is If I use 2 and above users to simultaneously Post it will consolidate all the data into one with the same Number.
What I want is to lock opening data until posted since i need to get the max number of a column then add 1 first then import a complete set of data including the MAX number as a control number.
I tried using Do While adStateOpen <> 1 and also Do While IsRecordBusy = True then wait and loop and set the recordset to nothing instead of closing it twice. But it wont work it will consolidate the data with the same control number.
Below is my Code
Option Explicit
Sub ImportJEData()
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
Dim Var
Dim LockType
Dim SQL
Dim IsRecordBusy
'add error handling
On Error GoTo errHandler:
'Variables for file path and last row of data
dbPath = Sheets("Update Version").Range("b1").Value
Set Var = Sheets("JE FORM").Range("F14")
nextrow = Sheets("LEDGERTEMPFORM").Cells(Rows.Count - 5, 1).End(xlUp).Row
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Create the ADODB recordset object. for Max Number
Set rst = New ADODB.Recordset 'assign memory to the recordset
LockType = adLockPessimistic
'Do While adStateOpen <> 1
Do While IsRecordBusy = True
Application.Wait (Now + TimeValue("0:00:01") / 1000)
Loop
SQL = "SELECT distinct Max(DVNumber),Max(ChckID) FROM DV "
rst.Open SQL, cnn
Sheets("Max").Range("A2").CopyFromRecordset rst
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.Open Source:="DV", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockPessimistic, _
Options:=adCmdTable
On Error Resume Next
'you now have the recordset object
'add the values to it
For x = 7 To nextrow
rst.AddNew
For i = 1 To 37
rst(Sheets("LEDGERTEMPFORM").Cells(6, i).Value) = Sheets("LEDGERTEMPFORM").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
'Update the sheet
Application.ScreenUpdating = True
'Clear the data
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
Im finally done with this code. I just added another Table in access where such table is unique the uses sql to get the max+1 and insert it back and loop it if error occurs because of the duplicate. Heres the code below
Do
On Error Resume Next 'reset Err.obj.
'Get the Max ID +1
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "SELECT Max(ApNumber)+1 FROM PayVoucherID "
rst.Open SQL, cnn
'Check if the recordset is empty.
'Copy Recordset to the Temporary Cell
Sheets("MAX").Range("A2").CopyFromRecordset rst
'Insert the Data to Database And Check If no Errors
Sql2 = "INSERT INTO PayVoucherID(ApNumber)Values('" & Sheets("MAX").Range("A2") & "') "
cnn.Execute Sql2
Loop Until (Err.Number = 0)
Hope this helps for Excel Front users.
I have been doing some database work with excel both as the database and the database driver via macros with vba. I built a function that should parse through a list of database records with testID fields. I wanted to display each test only once based on it's testID, but the way the database is set up means I have to eliminate duplicate testID's. I do this by iterating through the recordset and checking the current test against the previous one before showing in the list. The problem I'm having is that the function is excruciatingly slow. For only 12 tests in the database, it takes about 3 seconds to display them in the view spreadsheet. I'd love to hear some ideas on how to optimize the run-time. Here's the function:
Public Function showAllTests()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim cstring, sql As String
Dim r, c As Integer
Dim testsAr As Variant
Dim inAr As Boolean
cstring = "Provider = Microsoft.ACE.OLEDB.12.0; Data Source=I:\DBtrials.xlsx; Extended Properties=""Excel 12.0 Xml; HDR=YES;ReadOnly=False"";"
sql = "SELECT [TestID], [Status], [PFIBox], [WireType], [StartingDia], [Customer], [numSamples], [Assigned] FROM [Tests$]"
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Call conn.Open(cstring)
Set rs = conn.Execute(sql)
If rs.EOF Then
Range("C6:J1000").ClearContents
End If
r = 6
count = 0
'Iterates through the recordset, eliminating duplicates and populating cells in the tests sheet
While Not rs.BOF And Not rs.EOF
Dim prevID, currID As String
Dim currCell As Range
inAr = False
If Not count = 0 Then
prevID = ActiveWorkbook.Sheets("Tests").Cells(r - 1, 3).Value
currID = CStr(rs(0))
If prevID = currID Then
inAr = True
End If
End If
For c = 3 To (rs.Fields.count + 2)
Set currCell = ActiveWorkbook.Sheets("Tests").Cells(r, c)
If Not IsNull(rs(c - 3).Value) And inAr = False Then
currCell.Value = CStr(rs(c - 3))
ElseIf IsNull(rs(c - 3).Value) Then currCell.Value = ""
Else:
Exit For
End If
Next c
If inAr = False Then
r = r + 1
End If
rs.MoveNext
count = count + 1
Wend
conn.Close
Set conn = Nothing
End Function
use GROUP BY
sql = "SELECT [TestID], [Status], [PFIBox], [WireType], [StartingDia], [Customer], [numSamples], [Assigned] FROM [Tests$] GROUP BY [TestID]"
Also some of these drivers - Microsoft.ACE.OLEDB.12.0 etc have terrible perfomance in VBA. sometimes i get better perforamance from OBDC 6.2 than ADO
I am trying to update 4 cells in Excel 2010 to my MS Access 2010 using VBA the following code. The problem is that sometimes it update those fields in the table record and other times it is not. I wonder if anyone can shed some light on my code on what is causing to be inconsistent.
'Add a reference to the Microsoft ActiveX Data 2.8 or later Object Library
'via the Tool | References... in the VB-editor
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim stDB As String
Dim stCon As String
'Instantiate the ADO COM's objects.
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
'Pathway and name of the database
stDB = "P:\Quote Log.mdb"
'Create the connectionstring.
stCon = "Provider=Microsoft.Ace.OLEDB.12.0; Persist Security Info = False;" & _
"Data Source=" & stDB & ";"
'Open the connection
cnt.Open stCon
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Find and Update the record in Access
With rst
.Index = "PrimaryKey"
.CursorLocation = adUseServer
.Open "tbQuote", cnt, 1, 3, adCmdTableDirect
.Seek Range("dx32").Value
If Not rst.EOF Then
.Fields("QuoteNum") = Sheets("Quote Notice").Range("dx32").Value
.Fields("OtherCost") = Sheets("Cost").Range("b3").Value
.Fields("StocklistCost") = Sheets("Cost").Range("b4").Value
.Fields("DesignHrs") = Sheets("Cost").Range("b5").Value
.Fields("ProductionHrs") = Sheets("Cost").Range("b6").Value
.Update
Else
MsgBox "No such record...not updating."
End If
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Close the recordset and close the connection.
rst.Close
cnt.Close
Set cnt = Nothing
ExitSub:
Set rs = Nothing
'...and set to nothing if no such record
Exit Sub
thank you,
hughv
Okay, discovered my problem...this line needs to reference to the sheet and cell correctly.
.Seek Range("dx32").Value
to:
.seek Worksheet("Quote Notice").range("dx32").Value
I did a query on MS Access 2010, with the Query Builder, now I'm calling it from VBA. But when I try to use the recordcount to know how many records are on this query, the result is -1.
The code:
Public Function teste(Optional ByVal consulta As String, Optional ByVal cbAR_valor As String, Optional ByVal cbAR_valor2 As String)
Dim DB As ADODB.Connection
Dim RST As ADODB.Recordset
Dim Query As ADODB.Command
Dim parametro1 As ADODB.Parameter
Dim parametro2 As ADODB.Parameter
On Error GoTo trataErro
DB_Dir = ThisWorkbook.Path & "\" & "DB2.accdb"
Set DB = New ADODB.Connection
DB.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_Dir & ";Persist Security Info=False"
Set Query = New ADODB.Command
Set Query.ActiveConnection = DB
Query.CommandText = consulta
Query.CommandType = adCmdStoredProc
' Pego o valor do param. e adiciono no command
Set parametro1 = Query.CreateParameter("AR1", adChar, adParamInput, 255)
Query.Parameters.Append parametro1
parametro1.Value = cbAR_valor
' Pego o valor do param. e adiciono no command
Set parametro2 = Query.CreateParameter("AR2", adChar, adParamInput, 255)
Query.Parameters.Append parametro2
parametro2.Value = cbAR_valor2
Set RST = Query.Execute
a = RST.RecordCount
linha = 1
coluna = 1
ActiveWorkbook.Sheets("Plan2").Cells(CInt(linha), CInt(coluna)).CopyFromRecordset RST
DB.Close
Set DB = Nothing
Exit Function
trataErro:
MsgBox ("Erro: " & Err.Description)
End Function
RecordCount is tricky. Depending on the provider, data source type, and options, it may not be reliable.
For an ADO recordset, you are more likely to get a reliable RecordCount with a client-side cursor:
Set DB = New ADODB.Connection
DB.CursorLocation = adUseClient '<- add this
DB.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_Dir & ";Persist Security Info=False"
I assumed your procedure's consulta argument is a SQL statement. If that is correct, use adCmdText (instead of adCmdStoredProc) for CommandType:
Set Query = New ADODB.Command
'Set Query.ActiveConnection = DB ' Set not needed here ...
Query.ActiveConnection = DB
Query.CommandText = consulta
'Query.CommandType = adCmdStoredProc
Query.CommandType = adCmdText
If those changes were not sufficient to get you a reliable RecordCount, use MoveLast to ensure the recordset is fully populated before asking for RecordCount:
Set RST = Query.Execute
RST.MoveLast
MsgBox "RecordCount: " & RST.RecordCount
Add RST.MoveFirst afterward if you need the recordset pointer to be on the first row in preparation for your remaining operations.
When I've had trouble with counting records before, the issue was with the way the recordset was opened, not the connection. The cursor type needs to be static for it to work. This may be very similar to what HansUp was referring to with the cursorlocation in the connection object, though.
rec.Open querystr, con, 3
rec.movelast
cnt = rec.RecordCount
rec.movefirst