I am new to Excel VBA. I have a user form in which I am trying to populate names of those employees who are AMO. I have a database called Ofc. Under which I have a table EmployeeDetails. Primary key is PeoplesoftId.
Here is the structure and the contents of the Employee table:
PeoplesoftId Nameofemployee RacifId Employeeid Designation
43243309 Maddala V43309 99651823 AMO
43243310 Abhishek A43301 99651824 AMO
43243311 Atanu A43311 99651825 MO
43243312 Rajiv R43312 99651826 CSE
This is the code I've written so far:
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rs As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath As String
Dim SQL As String
Dim i As Integer
Dim var
'add error handling
On Error GoTo errHandler:
'Disable screen flickering.
Application.ScreenUpdating = False
dbPath = "E:\office_hsbc\ofc.accdb"
var = "AMO"
Set cnn = New ADODB.Connection ' Initialise the collection class variable
cnn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
cnn.Open
SQL = "SELECT Nameofemployee FROM EmployeeDetails where Designation= '" & var & "'"
Set rs = New ADODB.Recordset 'assign memory to the recordset
rs.Open SQL, cnn
If rs.EOF And rs.BOF Then
rs.Close
cnn.Close
'clear memory
Set rs = Nothing
Set cnn = Nothing
'Enable the screen.
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
comboamo.AddItem rs.Fields(i).Value, i
Next
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
MsgBox "Congratulation the data has been successfully Imported", vbInformation, "Import successful"
'error handler
On Error GoTo 0
Exit Sub
errHandler:
'clear memory
Set rs = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Import_Data"
You need to move through each record in the recordset. Currently you are trying to read all of the fields from a single record but your query only returns one field. Try this instead:
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
i = 0
Do Until rs.EOF
comboamo.AddItem rs.Fields("Nameofemployee").Value, i
rs.MoveNext
i = i + 1
Loop
rs.Close
Related
I have an Access 365 database that has Invoice Numbers, Due Dates, and Amounts Due. I'm trying to create an Excel UDF, whereby I input the Due Date and Invoice Number, and the function queries the database and returns the Amount Due.
The formula result is #Value and there's no compiler error, though there appears to be an error when it attempts to open the record set (I set up a error message box for this action). Perhaps there's an issue with my SQL? I'd appreciate any assistance with this matter.
I've found several discussions of similar topic, but I've been unable to get this code to work. I'd appreciate any assistance with this matter.
https://www.mrexcel.com/board/threads/need-help-creating-user-defined-functions-in-excel-to-query-from-a-database.943894/
Here's the code:
Function CLLData(inpDate As Long, inpInvoiceNum As String)
Dim conn As Object
Dim rs As Object
Dim AccessFilePath As String
Dim SqlQuery As String
Dim sConnect As String
'Disable screen flickering.
Application.ScreenUpdating = False
'Specify the file path of the accdb file.
AccessFilePath = ThisWorkbook.Path & "\" & "CRDD.accdb"
'Create the connection string.
sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFilePath
On Error Resume Next
'Create the Connection object.
Set conn = 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
On Error Resume Next
'Open the connection.
conn.Open sConnect
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Connection was not opened!", vbCritical, "Connection Open Error"
'Exit Sub
End If
On Error GoTo 0
'SQL statement to retrieve the data from the table.
SqlQuery = "SELECT [Value] FROM tblRawCallData WHERE (([DueDate] = '" & inpDate & "') AND ([Invoice] = '" & inpInvoiceNum & "'));"
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
Set rs = Nothing
Set conn = Nothing
MsgBox "Recordset was not created!", vbCritical, "Recordset Error"
'Exit Sub
End If
On Error GoTo 0
On Error Resume Next
'Open the recordset.
rs.Open SqlQuery, conn
'Check if the recordset was opened.
If Err.Number <> 0 Then
Set rs = Nothing
Set conn = Nothing
MsgBox "Recordset was not opened!", vbCritical, "Recordset open error"
'Exit Sub
End If
On Error GoTo 0
' Check there is data.
If Not rs.EOF Then
' Transfer result.
CLLData = rs!Value
MsgBox "Records: ", vbCritical, "Records"
' Close the recordset
Else
'Not found; return #N/A! error
CLLData = CVErr(xlErrNA)
MsgBox "No records in recordset!", vbCritical, "No Records"
End If
rs.Close
' Clean up
If CBool(conn.State And adStateOpen) Then conn.Close
Set conn = Nothing
Set rs = Nothing
'Enable the screen.
Application.ScreenUpdating = True
End Function
You need two or three corrections, as date values always should be handled as DateTime, and your invoice number most likely is numeric:
Function CLLData(inpDate As Date, inpInvoiceNum As String)
' <snip>
'SQL statement to retrieve the data from the table.
SqlQuery = "SELECT [Value] FROM tblRawCallData WHERE (([DueDate] = #" & Format(inpDate, "yyyy\/mm\/dd") & "#) AND ([Invoice] = " & inpInvoiceNum & "));"
Edit for numeric "date" and alpha-numeric invoice:
SqlQuery = "SELECT [Value] FROM tblRawCallData WHERE (([DueDate] = #" & Format(inpDate, "####\/##\/##") & "#) AND ([Invoice] = '" & inpInvoiceNum & "'));"
Seems like your function could be significantly less complex.
Comment out the error handler until you get it working when called from a Sub.
Function CLLData(inpDate As Long, inpInvoiceNum As String)
Dim conn As Object
Dim rs As Object
Dim AccessFilePath As String
Dim SqlQuery As String
Dim sConnect As String
AccessFilePath = ThisWorkbook.path & "\" & "CRDD.accdb"
sConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFilePath
On Error GoTo haveError
Set conn = CreateObject("ADODB.Connection")
conn.Open sConnect
SqlQuery = "SELECT [Value] FROM tblRawCallData WHERE [DueDate] = " & inpDate & _
" AND [Invoice] = '" & inpInvoiceNum & "'"
Set rs = CreateObject("ADODB.Recordset")
rs.Open SqlQuery, conn
If Not rs.EOF Then
CLLData = rs.Fields("Value").Value
Else
CLLData = CVErr(xlErrNA)
End If
rs.Close
Exit Function
haveError:
CLLData = "Error:" & Err.Description
End Function
Hi May Would Like to know why Copyfromrecordset wont work
Any work around using ADO?
I only have one Table One Number COlumn and it does not accept duplicates.
Also need to retrieve the ID number in order to be used by other codes for MultiUser Purpose.
Sub PostData()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset classe here
Dim dbPath
Dim x As Long, i As Long
'add error handling
On Error GoTo errHandler:
dbPath = Sheets("Sheet3").Range("h1").Value
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
Sql = "INSERT INTO DvID(DVnumber)SELECT Max(DVNumber)+1 FROM DvID "
rst.Open Sql, cnn
Sheet3.Range("A2").CopyFromRecordset rst
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
On Error GoTo 0
Exit Sub
errHandler:
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
See this paragraph in Remarks
It is not a good idea to use the Source argument of the Open method to perform an action query that does not return records because there is no easy way to determine whether the call succeeded. The Recordset returned by such a query will be closed. To perform a query that does not return records, such as a SQL INSERT statement, call the Execute method of a Command object or the Execute method of a Connection object instead.
If you work around with separate select and insert queries, the risk is that another user could create a record in between the two. Using an Auto-Increment key is preferred. With that caveat try
Sub PostData()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset classe here
Dim dbPath As String, sql As String
Dim newID As Long
'add error handling
On Error GoTo errHandler:
dbPath = Sheets("Sheet3").Range("h1").Value
Set cnn = New ADODB.Connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.Open "SELECT MAX(DVNumber)+1 FROM DvID", cnn
newID = rst(0)
cnn.Execute "INSERT INTO DvID(DVnumber) VALUES (" & newID & ")"
Sheet3.Range("A2") = newID
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
MsgBox newID & " Inserted", vbInformation
On Error GoTo 0
Exit Sub
errHandler:
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure PostData"
End Sub
Im making Codes Inserting Data into a autonumber Columns to a table that composes of Two COlumns.
My Table is Access and Front End is Excel. My Access Table contains ID (which is AutoNumber) and Paycode which is base on a cell. I need this codes to use it as Unique IDs in which later on will post it back to Ms Access separate Table.
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
Dim var
Dim PayIDnxtRow As Long
'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")
PayIDnxtRow = Sheets("MAX").Range("c1").Value
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Create the ADODB recordset object.
'Set rst = New ADODB.Recordset 'assign memory to the recordset
'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
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.
If rst.EOF And rst.BOF Then
'Close the recordet and the connection.
Sheets("Max").Range("A2") = 1
Else
'Copy Recordset to the Temporary Cell
Sheets("MAX").Range("A2").CopyFromRecordset rst
End If
'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)
'And if No errors COpy temporary to NEw Sub Temporary Data for Reference
Sheets("LEDGERTEMPFORM").Range("D1").Value = Sheets("MAX").Range("A2").Value
'Securing ChckID Seq Number
'ADO library is equipped with a class named Recordset
For x = 1 To PayIDnxtRow
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.AddNew
'Insert the Data to Database And Check If no Errors
Sql2 = "INSERT INTO PayPaymentID(ApNumber)Values('" & Sheets("LEDGERTEMPFORM").Range("B2") & "') "
cnn.Execute Sql2
Next x
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "Select PayID From PayPaymentID where APNumber = " & Sheets("LEDGERTEMPFORM").Range("B2") & " order by PayID "
rst.Open SQL, cnn
Sheets("PaySeries").Range("B2").CopyFromRecordset rst
Set rst = Nothing
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"
End Sub
In this section Below Would like to know if theres another way without using or even faster type of loop.
'Securing ChckID Seq Number
'ADO library is equipped with a class named Recordset
For x = 1 To PayIDnxtRow
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.AddNew
'Insert the Data to Database And Check If no Errors
Sql2 = "INSERT INTO PayPaymentID(ApNumber)Values('" & Sheets("LEDGERTEMPFORM").Range("B2") & "') "
cnn.Execute Sql2
Next x
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "Select PayID From PayPaymentID where APNumber = " & Sheets("LEDGERTEMPFORM").Range("B2") & " order by PayID "
rst.Open SQL, cnn
Sheets("PaySeries").Range("B2").CopyFromRecordset rst
Finally Ive figured it Out it went better from 40 to 19s Thanks to the idea of #miki180.
Heres my code below starting from DO...
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)
xlFilepath = Application.ThisWorkbook.FullName
SSql = "INSERT INTO PaypaymentID(Apnumber) " & _
"SELECT * FROM [Excel 12.0 Macro;HDR=YES;DATABASE=" & xlFilepath & "].[MAX$G1:G15000] where APNumber > 1"
cnn.Execute SSql
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "Select PayID From PayPaymentID where APNumber = " & _
Sheets("LEDGERTEMPFORM").Range("B8") & " order by PayID "
rst.Open SQL, cnn
Sheets("PaySeries").Range("B2").CopyFromRecordset rst
I have a form in Excel that writes to an Excel sheet. In the VBA below, I have requested the cells update an Access database.
There are no errors in uploading the data but when I go to my access sheet there is no data present.
Access table: (Click to enlarge)
Sub Export_Data()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim dbPath, x As Long, i As Long, nextrow As Long
On Error GoTo errHandler: 'add error handling
'Variables for file path and last row of data
dbPath = Sheet19.Range("I3").Value
nextrow = Cells(Rows.Count, 1).End(xlUp).Row
Set cnn = New ADODB.Connection 'Initialise the collection class variable
If Sheet18.Range("A2").Value = "" Then 'Check for data
MsgBox " Add the data that you want to send to MS Access"
Exit Sub
End If
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.Open Source:="SELECT * FROM [ARF Data Log]", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic
Options = adCmdOpenTable
'you now have the recordset object; add the values to it
For x = 2 To nextrow
rst.AddNew
For i = 1 To 29
rst(Cells(1, i).Value) = Cells(x, i).Value
Next i
rst.Update
Next x
rst.Close 'close the recordset
cnn.Close 'close the connection
Set rst = Nothing 'clear memory
Set cnn = Nothing
'communicate with the user
MsgBox " The data has been successfully sent to the access database"
Application.ScreenUpdating = True 'Update the sheet
Sheet19.Range("h7").Value = Sheet19.Range("h8").Value + 1 'show the next ID
Sheet18.Range("A2:ac1000").ClearContents 'Clear the data
On Error GoTo 0
Exit Sub
errHandler:
Set rst = Nothing 'clear memory
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Export_Data"
End Sub
You need to specify the fields you are updating. This is either done with ! or with .Fields. If you do not specify, you could use the index of the column.
- With !
Sub DataPopulation()
Dim myConn As New ADODB.Connection
Dim DBS As ADODB.Recordset
Set myConn = CurrentProject.Connection
Set DBS = New ADODB.Recordset
DBS.Open "SomeDB", myConn, adOpenKeyset, adLockOptimistic
DBS.AddNew
DBS!StudentNumber = 1
DBS!StudentName = "SomeName"
DBS!Grade = 10
DBS.AddNew
DBS!StudentNumber = 2
DBS!StudentName = "SomeFamilyName"
DBS!Grade = 10
DBS.Update
DBS.Close
Set DBS = Nothing
Set myConn = Nothing
End Sub
- With .Fields:
Do While Len(Range("A" & r).Formula) > 0
With rs
.AddNew
.Fields("Commodity #") = Range("A" & r).Value
.Update
End With
r = r + 1
Loop
- With Index: If you use the numerical index of the fields, then they start from 1 to the count of the fields. In your case rst(i) should be ok, if you have at least i columns. In the example below, there are 3 columns available:
For tblRow = 1 To 10
DBS.AddNew
For tblCol = 1 To 3
DBS(tblCol) = "Row: " & tblRow & " Col: " & tblCol
Next
Next
I'm using the below code to load a table from an MDB database to an excel worksheet. I'm trying to define the table name as variable and pass it to query but I'm getting an error with the code below. How can I do this in VBA?
Public Sub ReadMdb()
Dim cn As Object, rs As Object
Dim intColIndex As Integer
Dim DBFullName As String
Dim TargetRange As Range
DBFullName = Application.GetOpenFilename()
On Error GoTo Oops
Application.ScreenUpdating = False
Set TargetRange = Sheets("Sheet1").Range("A1")
Set cn = CreateObject("ADODB.Connection")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DBFullName
Set rs = CreateObject("ADODB.Recordset")
Dim tableName As String
tableName = "Students"
rs.Open "SELECT * FROM tableName", cn, , , adCmdText
' Write the field names
For intColIndex = 0 To rs.Fields.Count - 1
TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
Next
' Write recordset
TargetRange.Offset(1, 0).CopyFromRecordset rs
LetsContinue:
Application.ScreenUpdating = True
On Error Resume Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
On Error GoTo 0
Exit Sub
Oops:
MsgBox "Error Description :" & Err.Description & vbCrLf & _
"Error at line :" & Erl & vbCrLf & _
"Error Number :" & Err.Number
Resume LetsContinue
End Sub
you can insert table name into SQL:
rs.Open "SELECT * FROM [" & tableName & "]", cn, , , adCmdText
Considering your returning all the rows and all the columns, you could use the command type adCmdTable then you don't need any SQL you simply name the table that you want.