I have a multipleValue field which contains Multiple Designations like... Doctor,Nurse, ANM, Clerk etc.
I want to update a table where Designation Match with each Designation. My Code is following but success with First Designation only. How to Update all designation using code like.... DO Until.... Loop....Next.... in sql query
Private Sub PostAssigned_AfterUpdate()
Dim strCriteria As String
Dim varItem As Variant
Dim intCounter As Integer
Dim strClear, strUpdate As String
For Each varItem In Me![PostAssigned].Value
strCriteria = strCriteria & varItem & ","
Next
strClear = "UPDATE MasterGeneralData SET MasterGeneralData.DA_ID = 0 WHERE (((MasterGeneralData.DA_ID)= " & Me.DAAAID & "));"
DoCmd.RunSQL (strClear)
strUpdate = "UPDATE MasterGeneralData SET MasterGeneralData.DA_ID = " & Me.DAAAID & " WHERE (((MasterGeneralData.Emp_Design)= '" & Left$([strCriteria], InStr([strCriteria], ",") - 1) & "'));"
DoCmd.RunSQL (strUpdate)
MsgBox "Dealing Assistant details Updated successfully "
End Sub
Yes... I got it... Working Fine..
My code is.
Private Sub PostAssigned_AfterUpdate()
Dim strCriteria As String
Dim varItem As Variant
Dim intCounter As Integer
Dim strClear, strUpdate As String
Dim LArray() As String
For Each varItem In Me![PostAssigned].Value
strCriteria = strCriteria & varItem & ","
Next
LArray = Split(strCriteria, ",")
DoCmd.SetWarnings False
strClear = "UPDATE MasterGeneralData SET MasterGeneralData.DA_ID = 0 WHERE (((MasterGeneralData.DA_ID)= " & Me.DAAAID & "));"
DoCmd.RunSQL (strClear)
For i = LBound(LArray) To UBound(LArray)
strUpdate = "UPDATE MasterGeneralData SET MasterGeneralData.DA_ID = " & Me.DAAAID & " WHERE (((MasterGeneralData.Emp_Design)= '" & LArray(i) & "'));"
DoCmd.RunSQL (strUpdate)
Next i
DoCmd.SetWarnings True
MsgBox "Dealing Assistant details Updated successfully "
End Sub
Related
I need to scrub a regularly received Access database so that all of its tables can be exported to "clean" CSVs and then imported by Base SAS via PROC IMPORT.
I am not experienced with Access VBA or programming in general, but I attempted to kitbash a script to loop through every field in every table and replace certain characters. It doesn't appear to work and I get several "Type Conversion Failure" errors while it's running.
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Set db = CurrentDb()
Dim obj As AccessObject, dbs As Object
Set dbs = Application.CurrentData
' Cycle through all tables in database
For Each obj In dbs.AllTables
' Cycle through all fields in the table
For Each fld In db.TableDefs("[" & obj.Name & "]").Fields
If fld.Type = dbText And Not IsNull(fld) Then
strSQL = "Update [" & obj.Name & "] Set [" & fld.Name & "]= Replace([" & fld.Name & "],Chr(10),'. ')"
DoCmd.RunSQL strSQL
strSQL = "Update [" & obj.Name & "] Set [" & fld.Name & "]= Replace([" & fld.Name & "],Chr(13),'. ')"
DoCmd.RunSQL strSQL
End If
Next
Next obj
End Sub
Note that this particular code current only attempts to remove two characters. It's just a temporary testbed.
EDIT 2016.11.30: Just wanted to say that Andre's solution was perfect. I ended up needing to make a couple minor tweaks, particularly to also look at "memo" fields in addition to text fields and to write the helpful debug info to a text file rather than to the size-limited Immediate Window. Looping through an array of character codes was deceptively clever.
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim strFld As String
Dim arCharCodes As Variant
Dim code As Variant
Dim strFolder As String
Dim n As Integer
Dim strUpdate As String
' Get stuff setup save debug.print log file
strFolder = Application.CurrentProject.Path & "\" & Application.CurrentProject.Name & "_RemoveCharLog.txt"
n = FreeFile()
Open strFolder For Output As #n
' all charcodes to replace
arCharCodes = Array(10, 13, 44)
Set db = CurrentDb()
' Cycle through all tables in database
For Each td In db.TableDefs
' Ignore system tables
If Not (td.Name Like "MSys*" Or td.Name Like "USys*") Then
' Cycle through all fields in the table
For Each fld In td.Fields
If fld.Type = dbText Or fld.Type = dbMemo Then ' Check if field is text or memo
' Cycle through all character codes to remove
For Each code In arCharCodes
strFld = "[" & fld.Name & "]"
strSQL = "UPDATE [" & td.Name & "] " & _
"SET " & strFld & " = Replace(" & strFld & ", Chr(" & code & "), '. ') " & _
"WHERE " & strFld & " LIKE '*" & Chr(code) & "*'"
db.Execute strSQL
strUpdate = "Updated " & db.RecordsAffected & " records."
'Start printing logs
Debug.Print strSQL
Debug.Print strUpdate
Print #n, strSQL
Print #n, strUpdate
Next code
End If
Next fld
End If
Next td
End Sub
In principal there is nothing wrong with your code as far as I can see. The main problem may be that it also attempts to update all system tables - check "System objects" in the Navigation options of the navigation pane to see them.
They start with MSys or USys.
A few other things to improve:
You need the TableDef objects anyway, so you can directly loop them instead of AllTables
A table field cannot be Null, so this check isn't needed
For efficiency you want to only update rows where the column actually contains the searched character, so I add a WHERE clause
To avoid duplicate code, put all character codes to replace in an array for an additional loop.
Use db.Execute instead of DoCmd.RunSQL: it avoids the need for DoCmd.SetWarnings False, and gives you the number of affected records.
My suggestion:
Public Sub ReplaceCharAllTables()
Dim strSQL As String
Dim fld As DAO.Field
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim strFld As String
Dim arCharCodes As Variant
Dim code As Variant
' all charcodes to replace
arCharCodes = Array(10, 13)
Set db = CurrentDb()
' Cycle through all tables in database
For Each td In db.TableDefs
' Ignore system tables
If Not (td.Name Like "MSys*" Or td.Name Like "USys*") Then
' Cycle through all fields in the table
For Each fld In td.Fields
If fld.Type = dbText Then
For Each code In arCharCodes
strFld = "[" & fld.Name & "]"
strSQL = "UPDATE [" & td.Name & "] " & _
"SET " & strFld & " = Replace(" & strFld & ", Chr(" & code & "), '. ') " & _
"WHERE " & strFld & " LIKE '*" & Chr(code) & "*'"
Debug.Print strSQL
db.Execute strSQL
Debug.Print "Updated " & db.RecordsAffected & " records."
Next code
End If
Next fld
End If
Next td
End Sub
If this still gives errors, check the specific SQL (Ctrl+g shows the output of Debug.Print) - what column data type does it want to update?
rs2.FindFirst "[aniin] ='" & strTemp & "'"
aniin being an alias from the SQL within the function.
also tried ...
rs2.FindFirst (niin = newdata)
is my attempt to isolate the field name niin from the record value in the form from the one in the strSQL2. All my attempts have failed. I am trying to make sure that what the user typed in does match the list from the SQL string.
Private Function IsPartOfAEL(newdata) As Boolean
On Error GoTo ErrTrap
Dim db2 As DAO.Database
Dim rs2 As DAO.Recordset
Dim strTemp As String
strSQL2 = "SELECT tbl_ael_parts.master_ael_id, tbl_master_niin.niin as aniin " & vbCrLf & _
"FROM tbl_master_niin INNER JOIN tbl_ael_parts ON tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id " & vbCrLf & _
"WHERE (((tbl_ael_parts.master_ael_id)= " & Forms!frm_qry_niin_local!master_ael_id & "));"
Set db2 = CurrentDb
Set rs2 = db2.OpenRecordset(strSQL2)
strTemp = newdata
If rs2.RecordCount <> 0 Then
rs2.FindFirst "[aniin] ='" & strTemp & "'"
If rs2.NoMatch Then
IsPartOfAEL = False
Else
IsPartOfAEL = True
End If
Else
MsgBox "Query Returned Zero Records", vbCritical
Exit Function
End If
rs.Close
Set rs2 = Nothing
Set db2 = Nothing
ExitHere:
Exit Function
ErrTrap:
MsgBox Err.description
Resume ExitHere
End Function
First: You should never include a constant like vbCrLf when building a query string. The query parser doesn't care if there's a linefeed, and in fact this can sometimes cause issues.
Your code seems to do nothing more that verify whether the value in newdata exists in the tbl_ael_parts and is associated with the value master_ael_id value currently showing on frm_qry_niin_local. If so, then just use DCount, or use this for your query:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
" & Forms!frm_qry_niin_local!master_ael_id & ") AND niin=" & newdata & ");"
Dim rst As DAO.Recordset
Set rst = currentdb.OPenrecordset(strsql2)
If (rst.EOF and rst.BOF) Then
' no records returned
Else
' records found
End If
If niin is a Text field:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
" & Forms!frm_qry_niin_local!master_ael_id & ") AND (niin='" & newdata & "'));"
If both niin and master_ael_id are Text fields:
strSQL2 = "SELECT tbl_ael_parts.master_ael_id INNER JOIN tbl_ael_parts ON
tbl_master_niin.master_niin_id = tbl_ael_parts.master_niin_id WHERE (((tbl_ael_parts.master_ael_id)=
'" & Forms!frm_qry_niin_local!master_ael_id & "') AND (niin='" & newdata & "'));"
I have a userform with one textbox and one combobox in EXCEL.
This userform is connected to a small data base (one table with 2 columns)
Combobox is populated with the values from the first column of databasqe table
I like when the combobox is changing the textbox to be automatic populated with the corespondent value from the second column.
I have the following code but it is not working:
Please, can someone help me?
Sub PopulateTB()
Dim rs As Recordset
Dim db As database
Dim SQL As String
Set db = OpenDatabase(ThisWorkbook.Path & "\materiale.mdb")
SQL = "SELECT values_col2 FROM table_db WHERE values_col1 = " & UserForm1.ComboBox1.Value & ";"
Set rs = db.OpenRecordset(sql)
Do Until rs.EOF = True
UserForm1.TextBox1.Value = rs.Fields(SQL)
rs.MoveNext
Loop
rs.Close
Set db = Nothing
Set rs = Nothing
End Sub
Thank you!
I putted like this and it is ok
Sub PopulateTB(ByRef ctl As Control, ByVal strTable As String, ByVal strField As String, Optional ByVal strCriteria As String)
Dim strSQL As String
Dim strSQLcount As String
Dim rs As Recordset
Dim db As Database
Dim rsCount As Recordset, totalCol As Long
Dim varRecords As Variant
Set db = OpenDatabase(ThisWorkbook.Path & "\materiale.mdb")
strSQLcount = ""
strSQLcount = strSQLcount & " " & "SELECT COUNT(*) AS Total FROM " & "[" & strTable & "]"
Set rsCount = db.OpenRecordset(strSQLcount)
totalCol = rsCount!Total
rsCount.Close
Set rsCount = Nothing
strSQL = ""
strSQL = strSQL & " " & "SELECT" & "[" & strField & "]"
strSQL = strSQL & " " & "FROM " & "[" & strTable & "]"
Set rs = db.OpenRecordset(strSQL)
varRecords = rs.GetRows(totalCol)
ctl.Value = varRecords(0, Me.ComboBox1.ListIndex)
rs.Close
db.Close
Set db = Nothing
Set rs = Nothing
End Sub
I created an Access database which I want to distribute to a small group. While I can always export the tables in excel and merge them/append data there, is there a way to sync the databases, maybe by using VBA?
To expound further, in one form in the database application, a sync button may exist, and onclick, a dialog box may open to look for the accdb to sync with. What ensues is that the VBA will "sync" the table (which of course is of the same structure) in question between the two accdbs.
Is this possible? Insights will be good. Thank you!
Yes, it is perfectly possible. Here are some notes on comparing two DBs and logging changes.
The procedure requires the following at the top of the module:
Dim strFileNew As String
Dim strFileOld As String
Dim strLog As String
Dim dbOld As Database
The variables might contain:
strLog = "log.txt"
strFileNew = "z:\docs\dbNew.mdb"
strFileOld = "z:\docs\dbOld.mdb"
Set dbOld = OpenDatabase(strFileOld)
Then the comparison:
Sub LogCompareDB(db As Database)
''References : Windows Script Host Object Model
'' This is set by default for a number of versions
'' : Microsoft DAO x.x Object Library
'' For 2010, the DAO library is called
'' :Microsoft Office 12.0 Access Database Engine Object Library
Dim tdf As TableDef
Dim rs0 As DAO.Recordset
Dim rs1 As DAO.Recordset
Dim fld As DAO.Field
Dim idx As Index
Dim idxPrimary As Index
Dim strIndexList As String
Dim strIndex As String
Dim strID As String
Dim strSQL As String
Dim strChanged As String
Dim blnNew As Boolean
Dim fs As New FileSystemObject
Dim ts As TextStream
Set ts = fs.CreateTextFile(strLog, True)
''For each table in the old database
''(It would probably be a good idea to check the
''new database for added tables)
For Each tdf In db.TableDefs
'' Skip system tables
If Left(tdf.Name, 4) <> "MSys" Then
strIndex = vbNullString
Set idxPrimary = Nothing
strIndexList = vbNullString
''Get the primary index and index fields
For Each idx In tdf.Indexes
If idx.Primary = True Then
Set idxPrimary = idx
For Each fld In idx.Fields
strIndex = strIndex & " AND t0.[" & fld.Name _
& "] = t1.[" & fld.Name & "]"
strIndexList = strIndexList & "," & fld.Name
Next
strIndex = Mid(strIndex, 5)
End If
Next
''There is no basis for comparison if there is no index.
''A unique index would also be a possibility, but hey, let's
''not go over the top :)
If strIndex > vbNullString Then
''Select all records from the table for both databases
strSQL = "SELECT * FROM [;DATABASE=" & strFileNew & "].[" _
& tdf.Name & "] As t0 LEFT JOIN [" _
& tdf.Name & "] As t1 ON " & strIndex
Set rs0 = db.OpenRecordset(strSQL)
''A convenient list of fields from the old database
''It would probably be a good idea to check the
''new database for added fields.
strSQL = "SELECT * FROM [;DATABASE=" & strFileOld & "].[" _
& tdf.Name & "] As t0 WHERE 1=2"
Set rs1 = db.OpenRecordset(strSQL)
Do While Not rs0.EOF
strID = vbNullString
blnNew = False
''If the index fields are null, then it is a new record
For Each fld In idxPrimary.Fields
strID = strID & fld.Name & ": " & rs0("[t0." & fld.Name & "]") & vbCrLf
If IsNull(rs0("[t1." & fld.Name & "]")) Then
blnNew = True
End If
Next
If blnNew Then
''Write to log
ts.WriteLine "NEW RECORD " & strID & vbCrLf
Else
''Not a new record, so is it a changed record?
strChanged = vbNullString
For Each fld In rs1.Fields
''No need to check index fields, because they are equal
If InStr(strIndexList, fld.Name) = 0 Then
''Add null string for purposes of comparison ''trailing
If "" & rs0("[t0." & fld.Name & "]") <> "" & rs0("[t1." & fld.Name & "]") Then
strChanged = strChanged & vbCrLf _
& fld.Name & " Is: " & Trim(rs0("[t0." & fld.Name & "]")) _
& " Was: " & Trim(rs0("[t1." & fld.Name & "]"))
End If
End If
Next
If strChanged <> vbNullString Then
''Write to log
ts.WriteLine "CHANGED RECORD " & strID
ts.WriteLine strChanged & vbCrLf
End If
End If
rs0.MoveNext
Loop
Else
ts.WriteLine "NO PRIMARY INDEX " & tdf.Name & vbCrLf
End If
End If
Next
ts.Close
FollowHyperlink strLog
End Sub
Option Compare Database
Private Sub Command4_Click()
Dim tablename1, tablename2 As String
tablename1 = Text0.Value
tablename2 = Text2.Value
'On Error GoTo Err_cmdValidateGeneralInfo_Click
Dim F As DAO.Field
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Set curDB = CurrentDb()
'If Me.DateModified = Date Then
'Adds new employees to the TT_GeneralInfo table in the FTEI_PhoneBook.mdb - which is used thru out the AP databases.
' DoCmd.OpenQuery "qryEmpData_TT_General"
strsql = "Select * from " & tablename1
Set rs = curDB.OpenRecordset(strsql)
strsql1 = "Select * from " & tablename2
DoCmd.CopyObject , "Unmatched_records", acTable, tablename1
curDB.Execute "DELETE FROM Unmatched_records"
Set rs1 = curDB.OpenRecordset(strsql1)
Do Until rs.EOF
For Each F In rs.Fields
If rs.Fields(F.Name) <> rs1.Fields(F.Name) Then
'rs.Edit
strsql = "Select * into test from " & tablename1 & " where " & F.Name & " = """ & rs.Fields(F.Name) & """"
DoCmd.RunSQL strsql
If DCount(F.Name, "test") <> 0 Then
GoTo append_unmatch
'appending unmacthed records
append_unmatch:
strsql2 = "insert into Unmatched_records Select * from test"
DoCmd.RunSQL strsql2
'if record doesnt match move to next one
GoTo Nextrecord
End If
' rs.Fields(F.Name) = rs1.Fields(F.Name)
' rs.Update
End If
Next F
Nextrecord:
rs.MoveNext
rs1.MoveNext
Loop
If DCount("test", F.Name) <> 0 Then
MsgBox ("The two tables didnt match. Check table test for unmatching reocrds.")
Else
MsgBox ("Tables match!")
End If
End Sub
I'm currently trying to do multiple inserts from an access database to a remote sql server. Thus far I've had no luck. When I attempt to code in a workspace and transactions I receive a data mismatch error, but the functional insert works perfectly fine separately.
Here is my code: Transaction One has been commented out
Private Sub cmdInsSqlSrvr_Click()
On Error GoTo ErrHandler
Dim dbAccess As DAO.Database
Dim strTableName As String
Dim strSQL As String
Dim strSqlServerDB As String
Dim strTableName2 As String
Dim cInTrans As Boolean
Dim wsp As DAO.Workspace
strTableName = "po_header_sql"
strTableName2 = "po_line_Sql"
'<configuration specific to SQL Server ODBC driver>
strSqlServerDB = "ODBC;DRIVER={SQL Server};" & _
"Server=;" & _
"DATABASE=;" & _
"Uid=;" & _
"Pwd=;"
'Start Transaction One
'Set dbAccess = DBEngine(0)(0)
' strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE3 SELECT * FROM " & strTableName & ";"
'dbAccess.Execute strSQL, dbFailOnError
'InitConnect = True
'MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
'Command9.SetFocus
'cmdInsSqlSrvr.Enabled = False
'cmdInsertTbl.Enabled = True
' End Transaction One
'Begin Transaction Two
Set wsp = DBEngine(0)(0)
wsp.BeginTrans
Set dbAccess = wsp(0)
cInTrans = True
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE4 SELECT * FROM " & strTableName2 & ";"
dbAccess.Execute strSQL, dbFailOnError
InitConnect = True
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
wsp.CommitTrans
cInTrans = False
Command9.SetFocus
cmdInsSqlSrvr.Enabled = False
cmdInsertTbl.Enabled = True
'End Transaction Two
ExitProcedure:
On Error Resume Next
Set dbAccess = Nothing
Exit Sub
ErrHandler:
InitConnect = False
MsgBox Err.Description, vbExclamation, "Moving data to Sql Server failed: Error " & Err.Number
Resume ExitProcedure
End Sub
Fixed it by separating the insert statements and putting dbAccess.Execute after each one. Also cleaned up the code substantially. Code follows:
Private Sub cmdInsSqlSrvr_Click()
On Error GoTo ErrHandler
Dim dbAccess As DAO.Database
Dim strTableName As String
Dim strSQL As String
Dim strSqlServerDB As String
Dim strTableName2 As String
strTableName = "po_header_sql"
strTableName2 = "po_line_Sql"
'<configuration specific to SQL Server ODBC driver>
strSqlServerDB = "ODBC;DRIVER={SQL Server};" & _
"Server=<server ip>;" & _
"DATABASE=<database name>;" & _
"Uid=<database uid>;" & _
"Pwd=<database password>;"
Set dbAccess = DBEngine(0)(0)
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE3 SELECT * FROM " & strTableName & ";"
dbAccess.Execute strSQL, dbFailOnError
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName & " to remote DB")
strSQL = "INSERT INTO [" & strSqlServerDB & "].TABLE4 SELECT * FROM " & strTableName2 & ";"
dbAccess.Execute strSQL, dbFailOnError
InitConnect = True
MsgBox (dbAccess.RecordsAffected & " records have been moved from " & strTableName2 & " to remote DB")
Command9.SetFocus
cmdInsSqlSrvr.Enabled = False
cmdInsertTbl.Enabled = True
ExitProcedure:
On Error Resume Next
Set dbAccess = Nothing
Exit Sub
ErrHandler:
InitConnect = False
MsgBox Err.Description, vbExclamation, "Moving data to Sql Server failed: Error " & Err.Number
Resume ExitProcedure
End Sub