I am trying to import specific records from Access Tables to Excel spreadsheets based on a particular Date criteria. The code fails when it tries to execute the sql statement and the error message says
"DataType mismatch"
I have explored as many ways as I could think of or what I could find online to set the data type for the date but nothing seems to work. After modifying the code as it is now, I was able to get rid off the error message but code does not recognize the data in the access table. Any help will be greatly appreciated. Apologies in advance if my question does not make any sense. Trying to get my head around this being a newbie developer... Thanks for your patience.
Public Sub ImportData()
Application.ScreenUpdating = False
'
' Initialize shtArray (Public Array)
'
With ThisWorkbook
shtArray = Array(.Sheets("shtDom"))
End With
'
' Initialize tblArray (Public Array)
'
tblArray = Array("tbl_DOM")
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim dbPath As String
Dim SQL As String
Dim i As Integer
Dim sht As Worksheet, lastRow As Long
Dim dtDom As String, dtObk As String
If Weekday(frmInterface.dtPickDomestic, vbMonday) = 1 Then
dtDom = Format(frmInterface.dtPickDomestic - 3, "dd/mm/yyyy")
Else
dtDom = Format(frmInterface.dtPickDomestic - 1, "dd/mm/yyyy")
End If
If Weekday(frmInterface.dtPickOtherBanks, vbMonday) = 1 Then
dtObk = Format(frmInterface.dtPickOtherBanks - 3, "dd/mm/yyyy")
Else
dtObk = Format(frmInterface.dtPickOtherBanks - 1, "dd/mm/yyyy")
End If
dbPath = ThisWorkbook.Path & "\DOMESTIC SETTLEMENTS.mdb"
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
For i = LBound(tblArray) To UBound(tblArray)
Select Case i
Case 0, 8, 9
SQL = "SELECT * FROM " & tblArray(i) & " WHERE [BAL_DATE] = #" & dtDom & "#"
Case 10, 11, 12, 13
'SQL = "SELECT * FROM " & tblArray(i) & " WHERE [BAL_DATE] = #" & dtObk & "#"
Case Else
GoTo continue
End Select
Set sht = shtArray(i)
lastRow = sht.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
Set rs = New ADODB.Recordset
rs.Open SQL, con
If rs.EOF And rs.BOF Then
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
MsgBox "No records!!!", vbCritical
Exit Sub
End If
shtArray(i).Range("A" & lastRow).CopyFromRecordset rs
rs.Close
Set rs = Nothing
continue:
Next i
con.Close
Set con = Nothing
Set sht = Nothing
On Error GoTo 0
Exit Sub
errHandler:
Set rs = Nothing
Set con = Nothing
End Sub
Related
UPDATED QUESTION:
I have Update sheet, this sheet contains unique ID that matched the access database ID, I'm trying to update the fields using excel values in "Update" sheet.
The ID is in the Column A the rest of the fields are stored from Column B to R. I'm trying to achieve the below, As follows:
Update the record(values from Column B to R) if Column A (ID) matched existing Access database ID. Then add text in Column S "Updated"
If the Column A (ID) did not found any match in the existing Access database ID, Then add text in Column S "ID NOT FOUND"
Loop to next value
So far, I have the below Sub for Update and Function for Existing ID (Import_Update Module), but I'm getting this error.
Sub Update_DB()
Dim dbPath As String
Dim lastRow As Long
Dim exportedRowCnt As Long
Dim NotexportedRowCnt As Long
Dim qry As String
Dim ID As String
'add error handling
On Error GoTo exitSub
'Check for data
If Worksheets("Update").Range("A2").Value = "" Then
MsgBox "Add the data that you want to send to MS Access"
Exit Sub
End If
'Variables for file path
dbPath = Worksheets("Home").Range("P4").Value '"W:\Edward\_Connection\Database.accdb" '##> This was wrong before pointing to I3
If Not FileExists(dbPath) Then
MsgBox "The Database file doesn't exist! Kindly correct first"
Exit Sub
End If
'find las last row of data
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim cnx As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset class
On Error GoTo errHandler
'Initialise the collection class variable
Set cnx = New ADODB.Connection
'Connection class is equipped with a —method— named Open
cnx.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
'ADO library is equipped with a class named Recordset
Set rst = New ADODB.Recordset 'assign memory to the recordset
'##> ID and SQL Query
ID = Range("A" & lastRow).Value
qry = "SELECT * FROM f_SD WHERE ID = '" & ID & "'"
'ConnectionString Open '—-5 aguments—-
rst.Open qry, ActiveConnection:=cnx, _
CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
Options:=adCmdTable
'add the values to it
'Wait Cursor
Application.Cursor = xlWait
'Pause Screen Update
Application.ScreenUpdating = False
'##> Set exportedRowCnt to 0 first
UpdatedRowCnt = 0
IDnotFoundRowCnt = 0
If rst.EOF And rst.BOF Then
'Close the recordet and the connection.
rst.Close
cnx.Close
'clear memory
Set rst = Nothing
Set cnx = Nothing
'Enable the screen.
Application.ScreenUpdating = True
'In case of an empty recordset display an error.
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
For nRow = 2 To lastRow
'##> Check if the Row has already been imported?
'##> Let's suppose Data is on Column B to R.
'If it is then continue update records
If IdExists(cnx, Range("A" & nRow).Value) Then
With rst
For nCol = 1 To 18
rst.Fields(Cells(1, nCol).Value2) = Cells(nRow, nCol).Value 'Using the Excel Sheet Column Heading
Next nCol
Range("S" & nRow).Value2 = "Updated"
UpdatedRowCnt = UpdatedRowCnt + 1
rst.Update
End With
Else
'##>Update the Status on Column S when ID NOT FOUND
Range("S" & nRow).Value2 = "ID NOT FOUND"
'Increment exportedRowCnt
IDnotFoundRowCnt = IDnotFoundRowCnt + 1
End If
Next nRow
'close the recordset
rst.Close
' Close the connection
cnx.Close
'clear memory
Set rst = Nothing
Set cnx = Nothing
If UpdatedRowCnt > 0 Or IDnotFoundRowCnt > 0 Then
'communicate with the user
MsgBox UpdatedRowCnt & " Drawing(s) Updated " & vbCrLf & _
IDnotFoundRowCnt & " Drawing(s) IDs Not Found"
End If
'Update the sheet
Application.ScreenUpdating = True
exitSub:
'Restore Default Cursor
Application.Cursor = xlDefault
'Update the sheet
Application.ScreenUpdating = True
Exit Sub
errHandler:
'clear memory
Set rst = Nothing
Set cnx = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Update_DB"
Resume exitSub
End Sub
Function to Check if the ID Exists
Function IdExists(cnx As ADODB.Connection, sId As String) As Boolean
'Set IdExists as False and change to true if the ID exists already
IdExists = False
'Change the Error handler now
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim cmd As ADODB.Command 'dim the ADO command class
On Error GoTo errHandler
'Sql For search
Dim sSql As String
sSql = "SELECT Count(PhoneList.ID) AS IDCnt FROM PhoneList WHERE (PhoneList.ID='" & sId & "')"
'Execute command and collect it into a Recordset
Set cmd = New ADODB.Command
cmd.ActiveConnection = cnx
cmd.CommandText = sSql
'ADO library is equipped with a class named Recordset
Set rst = cmd.Execute 'New ADODB.Recordset 'assign memory to the recordset
'Read First RST
rst.MoveFirst
'If rst returns a value then ID already exists
If rst.Fields(0) > 0 Then
IdExists = True
End If
'close the recordset
rst.Close
'clear memory
Set rst = Nothing
exitFunction:
Exit Function
errHandler:
'clear memory
Set rst = Nothing
MsgBox "Error " & Err.Number & " :" & Err.Description
End Function
My below code is working fine. I tried to address your above three points in a different way.
##########################
IMPORTANT
1) I have removed your other validations; you can add them back.
2) DB path has been hard coded, you can set it to get from a cells again
3) My DB has only two fields (1) ID and (2) UserName; you will have obtain your other variables and update the UPDATE query.
Below is the code which is working fine to meet your all 3 requests...Let me know how it goes...
Tschüss :)
Sub UpdateDb()
'Creating Variable for db connection
Dim sSQL As String
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\test\db.accdb;"
Dim a, PID
'a is the row counter, as it seems your data rows start from 2 I have set it to 2
a = 2
'Define variable for the values from Column B to R. You can always add the direct ceel reference to the SQL also but it will be messy.
'I have used only one filed as UserName and so one variable in column B, you need to keep adding to below and them to the SQL query for othe variables
Dim NewUserName
'########Strating to read through all the records untill you reach a empty column.
While VBA.Trim(Sheet19.Cells(a, 1)) <> "" ' It's always good to refer to a sheet by it's sheet number, bcos you have the fleibility of changing the display name later.
'Above I have used VBA.Trim to ignore if there are any cells with spaces involved. Also used VBA pre so that code will be supported in many versions of Excel.
'Assigning the ID to a variable to be used in future queries
PID = VBA.Trim(Sheet19.Cells(a, 1))
'SQL to obtain data relevatn to given ID on the column. I have cnsidered this ID as a text
sSQL = "SELECT ID FROM PhoneList WHERE ID='" & PID & "';"
Set rs = New ADODB.Recordset
rs.Open sSQL, cn
If rs.EOF Then
'If the record set is empty
'Updating the sheet with the status
Sheet19.Cells(a, 19) = "ID NOT FOUND"
'Here if you want to add the missing ID that also can be done by adding the query and executing it.
Else
'If the record found
NewUserName = VBA.Trim(Sheet19.Cells(a, 2))
sSQL = "UPDATE PhoneList SET UserName ='" & NewUserName & "' WHERE ID='" & PID & "';"
cn.Execute (sSQL)
'Updating the sheet with the status
Sheet19.Cells(a, 19) = "Updated"
End If
'Add one to move to the next row of the excel sheet
a = a + 1
Wend
cn.Close
Set cn = Nothing
End Sub
You need to put the query inside the loop
Option Explicit
Sub Update_DB_1()
Dim cnx As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim qry As String, id As String, sFilePath As String
Dim lastRow As Long, nRow As Long, nCol As Long, count As Long
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Update")
lastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
sFilePath = wb.Worksheets("Home").Range("P4").Value
cnx.open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sFilePath
count = 0
For nRow = 2 To lastRow
id = Trim(ws.Cells(nRow, 1))
qry = "SELECT * FROM f_SD WHERE ID = '" & id & "'"
Debug.Print qry
rst.open qry, cnx, adOpenKeyset, adLockOptimistic
If rst.RecordCount > 0 Then
' Update RecordSet using the Column Heading
For nCol = 2 To 9
rst.fields(Cells(1, nCol).Value2) = Cells(nRow, nCol).Value
Next nCol
rst.Update
count = count + 1
ws.Range("S" & nRow).Value2 = "Updated"
Else
ws.Range("S" & nRow).Value2 = "ID NOT FOUND"
End If
rst.Close
Next nRow
cnx.Close
Set rst = Nothing
Set cnx = Nothing
MsgBox count & " records updated", vbInformation
End Sub
I'm new on this ADODB thing. I hope my question is not so silly. I open an ADODB connection from an Excel sheet (user interface) to another one ("database"). The code runs perfectly, but sometimes the updated or inserted data won't record in the database sheet. I don't know why and I don't know how to check it to avoid it happen. I do know that if I open the database sheet, save and then close, it works well again. Do someone know the reason for that?
The procedures of the code work well and the Excel VBA debugger does not get any error... Then I post some parts that I believe where the problem might be...
Public cn As ADODB.Connection
Public rst As ADODB.Recordset
Public sSQL As String
Public z, OP, Conf, TempoA, Setor As Double
Public FoundAp, FoundPar As Boolean
Private Sub txtCod_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Set cn = New ADODB.Connection
Set rst = New ADODB.Recordset
If Val(Application.Version) <= 11 Then 'Excel 2003 ou anterior
cn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & EstaPasta_de_trabalho.DbPath & ";" & _
"Extended Properties=Excel 8.0;"
Else 'Excel 2007 ou superior
cn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & EstaPasta_de_trabalho.DbPath & ";" & _
"Extended Properties=Excel 12.0 Xml;"
End If
cn.Open
'Instrução Sql:
sSQL = "SELECT * FROM [tb_Db_Ops$] " & _
"WHERE Cod_Apont LIKE " & txtCod & ";"
rst.CursorLocation = adUseServer
rst.Open sSQL, cn, adOpenKeyset, adLockOptimistic, adCmdText
If Not rst.EOF And Not rst.BOF Then
OP = rst!OP
frmApontamento.Visible = True
txtApontA = txtCod.Text
txtOpA = OP
txtEtapa.Text = rst!Etapa
txtDocA = rst!Documento
txtObraA = Mid(rst!Obra, 12)
Setor = CDbl(rst!Setor)
If IsNull(rst!Status) = False Then
Status = rst!Status
End If
If Status = "FINALIZADO" Then
frmMsg.lblMsg.Caption = "OP já finalizada!"
frmMsg.Show
rst.Close
cn.Close
Set rst = Nothing
Set cn = Nothing
Exit Sub
ElseIf Status = "EM EXECUÇÃO" Then
FoundAp = True
FoundPar = False
ElseIf Status = "" Then
FoundAp = False
FoundPar = False
Else
FoundAp = True
FoundPar = True
End If
Else
frmMsg.lblMsg.Caption = "Apontamento NÃO encontrado na Base de Dados! Supervisão notificada! Tente novamente mais tarde!"
frmMsg.Show
Email.ErroBd = True
Email.ErroGrav = False
Email.Proced = "txtCod_Exit"
Call Email_Erros
rst.Close
cn.Close
Set rst = Nothing
Set cn = Nothing
Exit Sub
End If
rst.Close
sSQL = "UPDATE [tb_Apontamentos$] " & _
"SET dt_f = NOW(), dt = NOW() - dt_i " & _
"WHERE Cod_Apont LIKE " & txtApontR & " AND dt_f IS NULL;"
cn.Execute sSQL
Final:
If Not (rst Is Nothing) Then
If rst.State = 1 Then
rst.Close
End If
Set rst = Nothing
End If
If Not (cn Is Nothing) Then
If cn.State = 1 Then
cn.Close
End If
Set cn = Nothing
End If
end sub
It takes some values from userform textboxes. It runs on a 2013 32 bits Excel version in Windows 10. The Microsoft ActiveX Data Objects 6.1 and Microsoft ActiveX Data Objects Recordset 6.0 libraries are activated. The interface is .xlsm and database is .xlsx
It sounds like you are trying to import data from a closed workbook. I haven't tried this in quite a while, but it sounds like the Macro Recorder is aware or the workbook that you are recording in/from, so the local workbook, but not the foreign workbook, so it loses references to the foreign workbook. See the code samples below.
Import data from a closed workbook (ADO)
If you want to import a lot of data from a closed workbook you can do this with ADO and the macro below. If you want to retrieve data from another worksheet than the first worksheet in the closed workbook, you have to refer to a user defined named range. The macro below can be used like this (in Excel 2000 or later):
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "A1:B21", ActiveCell, False
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "MyDataRange", Range ("B3"), True
Sub GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String, _
TargetRange As Range, IncludeFieldNames As Boolean)
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
' this will return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
' this will return data from any worksheet in SourceFile
' SourceRange must include the range headers
'
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
Dim TargetCell As Range, i As Integer
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"ReadOnly=1;DBQ=" & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ' open the database connection
Set rs = dbConnection.Execute("[" & SourceRange & "]")
Set TargetCell = TargetRange.Cells(1, 1)
If IncludeFieldNames Then
For i = 0 To rs.Fields.Count - 1
TargetCell.Offset(0, i).Formula = rs.Fields(i).Name
Next i
Set TargetCell = TargetCell.Offset(1, 0)
End If
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close ' close the database connection
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "The source file or source range is invalid!", _
vbExclamation, "Get data from closed workbook"
End Sub
Another method that doesn't use the CopyFromRecordSet-method
With the macro below you can perform the import and have better control over the results returned from the RecordSet.
Sub TestReadDataFromWorkbook()
' fills data from a closed workbook in at the active cell
Dim tArray As Variant, r As Long, c As Long
tArray = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:B21")
' without using the transpose function
For r = LBound(tArray, 2) To UBound(tArray, 2)
For c = LBound(tArray, 1) To UBound(tArray, 1)
ActiveCell.Offset(r, c).Formula = tArray(c, r)
Next c
Next r
' using the transpose function (has limitations)
' tArray = Application.WorksheetFunction.Transpose(tArray)
' For r = LBound(tArray, 1) To UBound(tArray, 1)
' For c = LBound(tArray, 2) To UBound(tArray, 2)
' ActiveCell.Offset(r - 1, c - 1).Formula = tArray(r, c)
' Next c
' Next r
End Sub
Private Function ReadDataFromWorkbook(SourceFile As String, SourceRange As String) As Variant
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
' this function can only return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
' this function can return data from any worksheet in SourceFile
' SourceRange must include the range headers
' examples:
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:A21")
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:B21")
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "DefinedRangeName")
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & SourceFile
Set dbConnection = New ADODB.Connection
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString ' open the database connection
Set rs = dbConnection.Execute("[" & SourceRange & "]")
On Error GoTo 0
ReadDataFromWorkbook = rs.GetRows ' returns a two dim array with all records in rs
rs.Close
dbConnection.Close ' close the database connection
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Function
InvalidInput:
MsgBox "The source file or source range is invalid!", vbExclamation, "Get data from closed workbook"
Set rs = Nothing
Set dbConnection = Nothing
End Function
See the link below.
https://www.erlandsendata.no/english/index.php?d=envbadacimportwbado
Check out this link as well.
https://www.rondebruin.nl/win/s3/win024.htm
I am working on an Excel application which allows users to enter hours work through userforms and info is stored in a Access DB. I am new to excel and access connections. I am able to connect to the database but record is not saved/created due to a run-time error at the .Update command.
Run-Time Error '-2147467259 (80004005)': Operation must use an updatable query.
I have searched and searched and can't find a solution to this problem. I hope someone is able to help. (code below)
Sub Export_Data_Access_TI1()
Dim dbPath As String
Dim x As Long, i As Long
Dim nextrow As Long
Dim user As String
Dim NewSht As Worksheet
Dim strQuery As String
Dim recDate As String
Dim Week_Of As String
user = Sheet1.Range("A1").Text
On Error GoTo ErrHandler:
'Variables for file path and last row of data
dbPath = "H:\PROJECTS\CAI_DOT-Time Tracker\CAI_EMP_SignIn_Database.accdb"
nextrow = Cells(Rows.Count, 1).End(xlUp).Row
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Check for data
If Sheets(user).Range("A2").Value = "" Then
MsgBox " There is no data to send to MS Access"
Exit Sub
End If
cnn.Mode = adModeReadWrite
'cnn.Mode = adModeShareDenyNone
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.CursorLocation = adUseClient
rst.Open Source:="DATA", ActiveConnection:=cnn, _
CursorType:=adOpenKeyset, LockType:=adLockPessimistic, _
Options:=adCmdTable
'rst.Supports (adAddNew)
x = 2 'the start row in the worksheet
Do While Len(Sheets(user).Range("A" & x).Formula) > 0
With rst
.AddNew 'create a new record
.Fields("Date") = ActiveWorkbook.Sheets(user).Range("A" & x).Value
.Fields("Week_Of") = Sheets(user).Range("B" & x).Value
.Fields("Month") = Sheets(user).Range("C" & x).Value
.Fields("Name") = Sheets(user).Range("D" & x).Value
.Fields("Time_In") = Sheets(user).Range("E" & x).Value
.Fields("Time_Out") = Sheets(user).Range("F" & x).Value
.Fields("Time_In2") = Sheets(user).Range("G" & x).Value
.Fields("Time_Out2") = Sheets(user).Range("H" & x).Value
.Fields("Group") = Sheets(user).Range("I" & x).Value
.Fields("UniqueID") = Sheets(user).Range("J" & x).Value
.Fields("Comments") = Sheets(user).Range("K" & x).Value
.Update 'stores the new record
End With
x = x + 1 'next row
Loop
rst.Close
cnn.Close
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
'Clear the data
'Sheets(user).Range("A1:K1000").ClearContents
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
As I understand, DATA is a query in the remote accdb. If so, it should be updateable. See, for example this: Why is my query not updateable? for criterias. If this is a table, check if you have read-write rights on accdb and the file has no read-only attribute.
I have a recordset object generated by the following code.
Private Sub GetID_Click()
'first find max id on sheet; used for if no ID is found on sheet
Dim myRange As Range
Dim maxIdOnSheet As Long
Dim clientSheet As Worksheet
Set clientSheet = Sheets("Client Codes")
Set myRange = clientSheet.Range("A1:A1048576")
maxIdOnSheet = WorksheetFunction.max(myRange) + 1
'set up connections with Nina's housing database
Dim cmd As New ADODB.Command
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strConn As String
Dim strSQL As String
Dim IDdb As Long
Dim IDwb As Long
'connection string
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\db\path\here\db.accdb; Persist Security Info=False"
'open connection database
conn.Open strConn
'sql statement
strSQL = "SELECT * FROM Clients WHERE (((Clients.FirstName)='" & FirstName.Value & "') AND ((Clients.LastName)='" & LastName.Value & "'));"
'open connection with the recordset
rs.Open strSQL, conn, adOpenDynamic, adLockOptimistic
'use the late-bound application match method to find out where the firstname and lastname values are in the worksheet, if found
Dim first As Long
Dim last As Long
Dim foundWB As Boolean
Dim foundDB As Boolean
foundWB = False
foundDB = False
Dim base As Long
Dim curRow As Long
base = 1
'First check to make sure if both values are in the worksheet
If Not IsError(Application.Match(FirstName.Value, Range("c" & base & ":c1048576"), False)) And Not IsError((Application.Match(LastName.Value, Range("b" & base & ":b1048576"), False))) Then
'if it is in the worksheet, find where it is
While found = False
first = Application.Match(FirstName.Value, Range("c" & base & ":c1048576"), False)
last = Application.Match(LastName.Value, Range("b" & base & ":b1048576"), False)
If first = last Then
foundWS = True
curRow = curRow + first
IDwb = Cells(curRow, 1)
Else
If first < last Then
base = first + 1
curRow = curRow + first
ElseIf last < first Then
base = last + 1
curRow = curRow + last
End If
End If
Wend
Else
'if its not in the WS, it is now the highest +1
IDwb = WorksheetFunction.max(Range("a1:a1048576")) + 1
End If
'find if its in the database
If rs.EOF Then
'if its not in the database, find the highest number and add 1
rs.Close
strSQL = "SELECT MAX(Clients.[Client ID]) FROM Clients;"
rs.Open strSQL, conn, adOpenDynamic, adLockOptimistic
IDdb = rs.Fields(0) + 1
MsgBox (rs.Properties.Item("Address"))
Else
'if it is, find the first column
IDdb = rs.Fields(0)
foundDB = True
MsgBox (rs.Properties.Item("Address"))
End If
If foundWB = True Then
ClientID.Value = IDwb
ElseIf foundDB = True Then
ClientID.Value = IDdb
Else
If IDdb > IDwb Then
ClientID.Value = IDdb
ElseIf IDwb > IDdb Then
ClientID.Value = IDwb
Else
ClientID.Value = IDwb
End If
End If
End Sub
I have two data sources - the worksheet this macro is located in Excel, and an Access database. I enter client data, and assign it a specific code. The code does that successfully.
I also want to fill out a userform based on that code which is received. The code above successfully queries the database and can get the client ID. I also want things like address, city, state, zip, household income, that is stored in the DB, from the query.
If I was doing this in strictly Excel, I would use a match statement, and if strictly through Access, a SQL query. I'm trying to run this query on both an Excel worksheet and an Access database at the same time, or in the same code. This requires setting up a recordset object: documentation is found here
http://www.w3schools.com/asp/ado_ref_recordset.asp and here
https://msdn.microsoft.com/en-us/library/ms675841(v=vs.85).aspx.
I know that I can get the information with something like
name = rs.fields(1)
address = rs.fields(4)
city = rs.fields(5)
'...
I'd rather get the index dynamically. If people change the database around I'd like for the formula to be stable.
Lets say if the field "Address" could be index 4, 5, 6, 7, until whenever.
How do I dynamically find the index of a specific field in a recordset object?
So, how do I dynamically find the index of a specific field in a recordset object? Lets say if the field "Address" could be index 4,5,6,7, until whenever.
There isn't a direct property in an ADO recordset to get this, but you can find it by looping through the fields and keeping a tally like I do in this function:
Public Function GetRecordsetFieldIndexFromName(rs As adodb.Recordset, ColumnName As String) As Variant
' Pass in an ADODB recordset and a column name and return the column index.
' Returns index in base 0.
' Ben S. - 11/8/2019
On Error GoTo ErrorHandler
Dim i As Long
If rs Is Nothing Then
' Recordset is not loaded
Else
For i = 0 To rs.Fields.count - 1
'Debug.Print i, rs.Fields(i).Name
If rs.Fields(i).Name = ColumnName Then
GetRecordsetFieldIndexFromName = i
Exit For
End If
Next
End If
Exit_Function:
Exit Function
ErrorHandler:
MsgBox "Error #" & err.Number & " - " & err.Description & vbCrLf & "in procedure GetRecordsetFieldIndexFromName"
GoTo Exit_Function
Resume Next
Resume
End Function
Here is a simple test that you can try in Access.
Public Sub TestADOrs()
' BS 11/8/2019 - Test for GetRecordsetFieldIndexFromName
Dim i As Long
Dim strSQL As String
Dim conn As New adodb.Connection
Dim rs As New adodb.Recordset
' Set an object pointing to the current database connection
Set conn = CurrentProject.Connection
strSQL = "Select Top 1 * From MSysObjects"
rs.Open strSQL, conn, adOpenStatic, adLockOptimistic
Debug.Print GetRecordsetFieldIndexFromName(rs, "Flags") ' This should return 4
Set rs = Nothing
Set conn = Nothing
End Sub
I made similar functions to this that work with List Box and Combo Box controls. They will let you return the index or the value from the control by passing the control and the column/field name.
https://stackoverflow.com/a/58773219/1898524 - Reference List Box Column by Field Name
I have created a form in which when I click a button(subMnuPrintStaff), it should open an Excel file(WorkerNames.xls). The Excel file gets its records from my database(Employee.mdb). However, the problem is that when I update my databasefile(Employee.mdb), the records on my Excel file does not get updated. How do I fix this?
I am using flexgrid.
BUTTON CODE:
Private Sub subMnuPrintStaff_Click()
'On Error GoTo er
Dim oExcel As Object
Set oExcel = CreateObject("Excel.Application")
Dim oWorkBook As Object
Dim oWorkSheet As Object
Dim i As Integer, k As Integer
Dim lRow As Long
Dim LastRow As Long
Dim LastCol As Long
oExcel.Visible = False
oExcel.Workbooks.Open App.Path & "\WorkerNames.xls"
Set oWorkSheet = oExcel.Workbooks("WorkerNames.xls").Sheets("WorkerNames")
i = 2 'Row in Excel
LastRow = DataGrid1.Row 'Save Current row
LastCol = DataGrid1.Col 'and column
DataGrid1.Row = 0 'Fixed Row is -1
Do While DataGrid1.Row <= DataGrid1.VisibleRows - 1
For k = 1 To DataGrid1.Columns.Count - 1
DataGrid1.Col = k 'Fixed Column is -1
oWorkSheet.Cells(i, k).Font.Bold = False
oWorkSheet.Cells(i, k).Font.Color = vbBlack
oWorkSheet.Cells(i, k).Value = DataGrid1.Text
Next
i = i + 1
If DataGrid1.Row < DataGrid1.VisibleRows - 1 Then
DataGrid1.Row = DataGrid1.Row + 1
Else
Exit Do
End If
Loop
DataGrid1.Row = LastRow 'Restore original Row
DataGrid1.Col = LastCol 'and Column
oExcel.Workbooks("WorkerNames.xls").Save
oExcel.Workbooks("WorkerNames.xls").Close savechanges:=True
oExcel.Quit
'cmdView.Enabled = True
'er:
'If err.Number = 1004 Then
'Exit Sub
'End If
On Error GoTo ErrHandler
Dim xlApp As Object
Dim xlWB As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Open("WorkerNames.xls")
Exit Sub
ErrHandler:
MsgBox "There is a problem opening that workbook!", vbCritical, "Error!"
End Sub
FORM LOAD CODE:
Dim oRs As New ADODB.Recordset
Dim adoConn2 As ADODB.Connection
Set adoConn2 = New ADODB.Connection
adoConn2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & App.Path & "\Employee.mdb"
adoConn2.Open
oRs.CursorLocation = adUseClient
oRs.Open "select * from employeeName", adoConn2, adOpenKeyset, adLockPessimistic
Set DataGrid1.DataSource = oRs
DataGrid1.Refresh
Any help would be greatly appreciated. Database and Excel files are in the same directory with the project.
CODE FOR SAVING DATA INTO MY DATABASE - using text boxes
Dim adoConn As New ADODB.Connection Dim constr, curSql As String constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\employee.mdb;Persist Security Info=False"
Set adoConn = New ADODB.Connection
adoConn.ConnectionString = constr adoConn.Open
If txtFirstName.Text = "" Or txtLastName.Text = "" Then
MsgBox "Some fields are empty!", vbInformation + vbOKOnly, "Empty Fields"
Else curSql = "INSERT INTO employeename(Firstname, LastName) VALUES ("curSql = curSql & "'" & Replace(txtFirstName.Text, "'", "''") & "'," curSql = curSql & "'" & Replace(txtLastName.Text, "'", "''") & "')"
adoConn.Execute curSql
adoConn.Close
MsgBox "Data successfully added!", vbOKOnly, "Success!"
txtFirstName.Text = ""
txtLastName.Text = ""