No data importing from Excel to Access with ADO - vba

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

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... :)

Excel VBA - writing Data from SQL/Recordset very slow

I am trying to write SQL Server data to an Excel sheet but it is very slow. Is there something to optimize? Approximately, 4000 entries at 20 cColumns takes 6-7 minutes.
Database ("freigabe") Module: Connecting to Database and get RecordSet
(this works like a charm)
Private Function ConnectSQL() As ADODB.Connection
Set conn = New ADODB.Connection
conn.ConnectionString = "DRIVER={SQL Server};" _
& "SERVER=xxxxx;" _
& " DATABASE=xxxxx;" _
& "UID=xxxxxx;PWD=xxxxx; OPTION=3"
conn.Open
Set ConnectSQL = conn
End Function
Public Function load(Optional ByVal FieldName As String = "", Optional ByVal fieldValue As String = "", Optional ByVal ComparisonOperator As String = "=")
'wenn fehler return?
'-> Über errorhandler retun rs oder boolen
Dim rs As New ADODB.Recordset
Dim sql As String
Dim contition As String
contition = " "
Dim sqlfrom As String
Dim sqlto As String
On Error GoTo Fehler:
sql = "SELECT * FROM " & TBLNAME & " WHERE storno='0' AND created BETWEEN '2020-02-01' AND '2020-02-15'"
Set conn = ConnectSQL()
rs.Open sql, conn, adOpenStatic
Set load = rs
Exit Function
End If
Fehler:
load = Err.Description
End Function
Get/Write: Build a connection and retrieving recordset. The While loop is taking long. I am skipping text-rich columns (it gets faster but still too long). Showing a load-window so the person doesn't think that Excel "isn't working". After that, the data get's validated (not included).
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rs As Recordset
Dim k As Integer
Dim i As Integer
Dim startt As Double
Dim endt As Double
Dim rngDst As Range
Set rs = freigabe.load()
Set rngDst = Worksheets("Freigaben").Range("G2")
With Worksheets("Freigaben").Range("g2:Z50000")
.ClearContents
'.CopyFromRecordset rs
End With
Count = rs.RecordCount
k = 0
gui_laden.Show
startt = Timer
With rs
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
While Not .EOF
For i = 0 To .Fields.Count - 1
If i <> 13 And i <> 2 And i <> 10 And i <> 5 And i <> 6 And i <> 0 Then rngDst.Offset(, i) = .Fields(i).Value 'skip unneccessary data and write
Next i
k = k + 1
Debug.Print k & "/" & Count
gui_laden.lbl_status = "Lade Daten herunter: " & k & "/" & Count
gui_laden.Repaint
.MoveNext
DoEvents 'Ensure Application doesn't freeze
Set rngDst = rngDst.Offset(1)
Wend
End If
End With
endt = Timer - startt
Debug.Print "Dauer: " & endt
What I tried:
CopyFromRecordSet -> Application freezes
Test in new workbook -> same
Thank you very much!

Using an existing external data connection to create a recordset

I have a macro that I use to get data from an Access database, pass it into a recordset and then drop it into a worksheet in a crosstab format. Currently all my data starts in a SQL Server, gets pulled into Access, and then my macro takes it from there.
I’m trying to cut Access out of the process. What I need is the code to point at an external data source rather than to an Access mdb, which results in me getting the same recordset for the rest of the macro to process. My whole code is below; I’ve marked the part I’m looking to change.
' Gets the prior incurred claims estimates data from the Access database
' "RestatedIncurredClaims.mdb" in the same folder as the model, and sets up
' the tables on the Prior_Claims sheet to contain the data.
Public Sub GetPriorClaimsData()
If [MODEL_NAME] = "" Then
Dim modelName As String
modelName = Replace(ThisWorkbook.Name, "ReserveModel_", "")
modelName = Left(modelName, InStr(modelName, ".") - 1)
[MODEL_NAME] = modelName
End If
' WANT TO CHANGE THIS PART
Dim dbPath As String
dbPath = ThisWorkbook.Path & "\RestatedIncurredClaims.mdb"
Application.Calculation = xlCalculationManual
On Error GoTo priorClaimsErr
Application.StatusBar = "Opening prior claims database..."
' Open the database
' Options:=False means non-exclusive, see:
' http://msdn.microsoft.com/en-us/library/office/ff835343.aspx
Dim db As Database
Set db = Workspaces(0).OpenDatabase(Name:=dbPath, _
Options:=False, ReadOnly:=True)
Application.StatusBar = "Getting prior claims data..."
' Execute query to get prior incurred claim estimates for this model only
Dim rs As Recordset
Set rs = db.OpenRecordset( _
"SELECT * FROM [Restated incurred claims] WHERE [model_name] = """ _
& [MODEL_NAME] & """")
' WANT TO LEAVE EVERYTHING ELSE THE SAME
Dim i As Long, numCellsFound As Long
Dim iLOB As Long, iTOS As Long, iReported As Long, iIncurred As Long
numCellsFound = 0
' Create the array that will hold the prior claims data during processing
Dim priorClaimsData() As Variant
ReDim priorClaimsData( _
0 To [PRIOR_CLAIMS_TABLES].Rows.Count - 1, _
0 To [PRIOR_CLAIMS_TABLES].Columns.Count - 1)
If rs.RecordCount > 0 Then
Application.StatusBar = "Clearing prior claims data..."
[PRIOR_CLAIMS_TABLES].ClearContents
Dim lookupLOB As New Dictionary
For i = 1 To [LST_LINES].Cells.Count
lookupLOB([LST_LINES].Cells(i).Value) = i
Next
Dim lookupTOS As New Dictionary
For i = 1 To [LST_TYPES_SHORT].Cells.Count
lookupTOS([LST_TYPES_SHORT].Cells(i).Value) = i
Next
Dim lookupDate As New Dictionary
For i = 1 To [PRIOR_CLAIMS_DATES].Cells.Count
lookupDate([PRIOR_CLAIMS_DATES].Cells(i).Value) = i
Next
rs.MoveFirst
Do Until rs.EOF
If rs.AbsolutePosition Mod 1000 = 0 Then
Application.StatusBar = "Processing prior claims data, row " _
& Format(rs.AbsolutePosition, "#,0") & "..."
End If
iLOB = lookupLOB(CStr(rs!model_lob))
iTOS = lookupTOS(CStr(rs!fnc_ben_typ_cd))
iReported = lookupDate(CStr(rs!acct_perd_yr_mo))
iIncurred = lookupDate(CStr(rs!clm_incr_yr_mo))
If iLOB <> 0 And iTOS <> 0 _
And iReported <> 0 And iIncurred <> 0 Then
iLOB = iLOB - 1
iTOS = iTOS - 1
iReported = iReported - 1
iIncurred = iIncurred - 1
priorClaimsData( _
iLOB * ROWS_PER_LOB + iIncurred, _
iTOS * COLS_PER_TOS + iReported) = rs!rst_incur_clm
numCellsFound = numCellsFound + 1
End If
rs.MoveNext
Loop
[PRIOR_CLAIMS_TABLES].Value = priorClaimsData
End If
If numCellsFound = 0 Then
MsgBox Prompt:="No prior estimates data found for this model (" _
& [MODEL_NAME] & ").", _
Title:="Warning", _
Buttons:=vbExclamation + vbOKOnly
End If
GoTo closeDb
priorClaimsErr:
MsgBox Prompt:="Failed to update the prior claim estimates data:" _
& vbCrLf & vbCrLf & Err.Description, _
Title:="Warning", _
Buttons:=vbExclamation + vbOKOnly
closeDb:
Application.StatusBar = "Closing prior claims database..."
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
If Not db Is Nothing Then
db.Close
Set db = Nothing
End If
Application.StatusBar = "Recalculating..."
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub
I initially thought that if I established the data connection and had it saved in an .odc file, that referencing that file in vba would be simple. But all I’ve been able to find is code for establishing new data connections directly in vba with a connection string. Is this what I have to do? If so is there a way to do it so that the code will work regardless of the user running it?
I'm using Excel 2010
Thanks
This is an ADO code sample you can use to connect to SQL Server:
You must add a reference to 'Microsoft ActiveX Data Objects 6.1' first
SQLSERVER_CONN_STRING = "Provider=SQLOLEDB.1;Data Source=<server name or IP address>;User ID=<User_id>;Password=<pwd>;Initial Catalog=<initial cat>;"
Dim oConn As ADODB.Connection
Dim rs as ADODB.Recorset
Dim sSQL as String
Set oConn = New ADODB.Connection
oConn.CommandTimeout = 60
oConn.ConnectionTimeout = 30
oConn.Open SQLSERVER_CONN_STRING
Set rs = New ADODB.Recordset
'note that SQL Server query syntax is different!
sSql = "SELECT * FROM [Restated incurred claims] WHERE [model_name] = '" & [MODEL_NAME] & "'")
rs.Open sSQL, oConn, adOpenStatic, adLockOptimistic, adCmdText
If Not rs Is Nothing Then
If rs.State = 1 Then
If rs.RecordCount > 0 Then
<your code here>
end if
End If
End If
If Not rs Is Nothing Then
If rs.State = 1 Then rs.Close
End if
If Not oConn Is Nothing Then
If oConn.State = 1 Then oConn.Close
End if

Error 91 (Object Not Set) When Finding Data in Closed Workbook

I have two workbooks, call them Book1 and Book2. Book1 is open, and I am trying to get data from Book2, which is closed, into Book1. Book1 contains a column listing a corresponding element in Book2. For example, Book1 has a column of numbers that correspond to another list of numbers in Book2. I am trying to use VBA to get data from a row in Book2 with the matching number to the one in Book1.
Right now, I have the following MWE that generates an Error 91 (Object Not Set) when I try to execute the code:
Dim path As String, book As String, sheet As String
Dim targetRng As Range, sourceRng As Range
path = Left(Cells(2, 1).Value, InStrRev(Cells(2, 1).Value, "\"))
book = Dir(Cells(2, 1).Value)
sheet = Cells(2, 2).Value
Set targetRng = Range("A1").CurrentRegion
Set targetRng = targetRng.Offset(1, 0).Resize(targetRng.Rows.Count - 1) 'Ignore header row
For i = 1 To targetRng.Rows.Count
Set sourceRng = "'" & path & "[" & book & "]" & sheet & "'!" & Range("A:A").Find(targetRng.Cells(i, 1).Value) 'Error is here
targetRng.Cells(i, 2).Value = ExecuteExcel4Macro("'" & path & "[" & book & "]" & sheet & "'!" & Cells(sourceRng.Row, 2).Address)
'
'Do some other stuff
'
Next i
I was reluctant to provide an answer using the ADO because it is a broad topic. But I will provide you two examples of how you con query a Excel files using the ADO.
On the left we have the source file that we will be querying [Employees.xlsx]. On the right we workbook that we are updating [Sample.xlsm]. In my examples we are using [Sheet1] of booth workbooks. Note that the ADO will use column headers as field names (id,first_name,last_name...etc.).
In Example1 we query [Employees.xlsx] loading all the records from [Employees.xlsx]![Sheet1] into the recordset EmployeeData. Next we iterate over the id column of [Sample.xlsm]![Sheet1] and setting the filter of the recordset EmployeeData.Filter = "id=" & Cells(x, 1). Then copy the values of the records fields to the appropriate cell .Cells(x, 2) = EmployeeData.Fields("first_name")
Sub Example1()
Dim lastRow As Long, x As Long
Const adOpenKeyset = 1
Const adLockOptimistic = 3
Dim conn
Dim EmployeeData
Set conn = CreateObject("ADODB.Connection")
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=I:\stackoverflow\Employees.xlsx;Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
conn.Open
On Error GoTo CloseConnection
Set EmployeeData = CreateObject("ADODB.Recordset")
With EmployeeData
.ActiveConnection = conn
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = "Select * FROM [Sheet1$]"
.Open
On Error GoTo CloseRecordset
End With
With Worksheets("Sheet1")
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For x = 2 To lastRow
EmployeeData.Filter = "id=" & Cells(x, 1)
If Not (EmployeeData.BOF And EmployeeData.EOF) Then
.Cells(x, 2) = EmployeeData.Fields("first_name")
.Cells(x, 3) = EmployeeData.Fields("last_name")
.Cells(x, 4) = EmployeeData.Fields("email")
.Cells(x, 5) = EmployeeData.Fields("gender")
.Cells(x, 6) = EmployeeData.Fields("ip_address")
End If
Next
End With
CloseRecordset:
EmployeeData.Close
Set EmployeeData = Nothing
CloseConnection:
conn.Close
Set conn = Nothing
End Sub
In Example2 we Left Join [Sample.xlsm]![Sheet1] with [Employees.xlsx]![Sheet1]. In this way, we use CopyFromRecordset to update the data for us.
Sheet1.Range("A2").CopyFromRecordset EmployeeData.
Sub Example2()
Dim lastRow As Long, x As Long
Const adOpenKeyset = 1
Const adLockOptimistic = 3
Dim conn
Dim EmployeeData
Set conn = CreateObject("ADODB.Connection")
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
conn.Open
On Error GoTo CloseConnection
Set EmployeeData = CreateObject("ADODB.Recordset")
With EmployeeData
.ActiveConnection = conn
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Source = "SELECT table1.id, table2.[first_name], table2.[last_name], table2.[email], table2.[gender], table2.[ip_address] FROM ( [Sheet1$] table1 LEFT JOIN `I:\stackoverflow\Employees.xlsx`.`Sheet1$` table2 ON table2.[id]=table1.[id] )"
.Open
On Error GoTo CloseRecordset
End With
Sheet1.Range("A2").CopyFromRecordset EmployeeData
CloseRecordset:
EmployeeData.Close
Set EmployeeData = Nothing
CloseConnection:
conn.Close
Set conn = Nothing
End Sub
Note: CopyFromRecordset will replace all the data in the effected columns. For this reason recommend using Example 1 until you become comfortable writing queries.

SQL query to extract employee details from access table

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