Remove All Control Characters In All String Fields In All Tables In Access Database - vba

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?

Related

Trying to add a filter condition to TransferSpreadsheet using DAO and Me.filter

There is a button on a report that exports the underlying query of the report to excel. This function works fine as it would but I need it to take the criteria of the report. I have a massive reporting manager that will set the criteria for the report and then will open it up.
To make it easy, I want to pass me.filter to a variable which works in a different sub, but here my problem is that I need to pass the filter to be properly formatted for an sql statement I assume? The other sub just uses it as a [WhereCondition] for an open report command.
For clarification, the portion getreportsource() is a module that gets the reports source and it works fine.
Here are some example outputs of the variables as well as the code:
strRptName: TotalSalesForYear
strRptSource: qryMainDashboard
FilterCondition: TxnDate >= #11/1/2017# AND TxnDate <= #11/30/2017#
Private Sub cmdExcel_Click()
Dim strRptName As String
Dim strRptSource As String
Dim vardate As String
Dim varExportPath As String
Dim FilterCondition As String
Dim oExcel
FilterCondition = Me.filter
' Get the Report Name
strRptName = Screen.ActiveReport.Name
' Get the RecordSource of the Report from a module
strRptSource = GetReportSource(strRptName)
'Present Date
vardate = Format$(Now(), "YYYY.MM.DD_HH-mm-ss")
'Path of export
varExportPath = "C:\Users\Public\Downloads\"
'Check for terminating backslash ExportLinkReportsOut filepath.
If Right(varExportPath, 1) <> "\" Then
varExportPath = varExportPath & "\"
End If
varExportPath = varExportPath & strRptName & ".xlsx"
' set dao and create temp table
Dim cdb As DAO.Database, qdf As DAO.QueryDef
Const tempTableName = "_tempTbl"
Set cdb = CurrentDb
'deletes temp table and handles error
On Error Resume Next
DoCmd.DeleteObject acTable, tempTableName
On Error GoTo 0
Set qdf = cdb.CreateQueryDef("")
qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] where filtercondition"
qdf.Execute
Set qdf = Nothing
Set cdb = Nothing
' export spreadsheet with the temp table, the export path, and then open the spreadsheet
DoCmd.TransferSpreadsheet acExport, , tempTableName, varExportPath, True
Set oExcel = GetObject(varExportPath)
oExcel.Application.Visible = True
oExcel.Parent.Windows(1).Visible = True
End Sub
Everything works when I change qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] where filtercondition" to qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] "
Problem is there is no filter when I drop filtercondition, obviously.
The error I keep getting is "Run-time error '3061': Too few paramters. Expected 1."
Anyone have any pointers?
The problem is that you aren't concatenating the filter condition. Your query just states WHERE filtercondition, not WHERE TxnDate >= #11/1/2017# AND TxnDate <= #11/30/2017#
Change qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] where filtercondition" to qdf.SQL = "SELECT * INTO [" & tempTableName & "] FROM [" & strRptSource & "] WHERE " & filtercondition

Access Split column data w semi-colon into normalize table structure

I have a table, which was pulled out of some XML data. I'm trying to do a cross reference, so I can line out a plan for organizing the data. This 1 table has a list of variables. Fields of different data types, computations, as well as dialogs. One of the columns has options. If the data type of the variable is a dialog, its options has a list of variables, separated by a semi-colon.
So the main table has a structure like so:
For the dialog records I need to look through their options column and insert records into a normalized table. For each field, in that column, I want to add a record with that dialog name, and the ID of the row in that table (I added a PK to the table). For instance, in the dialog record, Options column, there is a field in there called BusinessName TE. I need to search this main table for the PK ID of the row that has a variable name of the same. I need to put that record's ID with the name of the dialog, and insert both into a new table I set up. This will create a cross reference for me, so I can know which variables are being used by which dialogs.
I appreciate any help anyone can give. I see stuff about using a split function, arrays and looping through to get each value, but the examples I'm finding are for strings, not a column in a table.
Thanks!
Edit: Adding in the VBA code I'm working with. I attached it to a button on a form, just so I could click to run it.
Private Sub RunParse_Click()
Dim db As DAO.Database
Dim rs As Recordset
Set db = CurrentDb()
Dim sqlStr, insertSQL, arrayVal As String
Dim TestArray As Variant
Dim Options As String
Dim Dialog As String
Dim FieldName As Long
Dim i As Integer
sqlStr = "SELECT [MASTER Fields].Options,[MASTER Fields].[Variable Name] FROM [MASTER Fields] WHERE ((([MASTER Fields].[Variable Type])='dialog'));"
Set rs = db.OpenRecordset(sqlStr)
rs.MoveLast
rs.MoveFirst
Do While Not rs.EOF
Options = rs.Fields(0)
Dialog = rs.Fields(1)
If InStr(Options, ";") Then
TestArray = Split(Options, ";")
For i = 0 To UBound(TestArray) - LBound(TestArray) + 1
If TestArray(i) <> "" Then
arrayVal = TestArray(i)
FieldName = DLookup("ID", "MASTER Fields", "[Variable Name] = " & "'" & arrayVal & "'")
insertSQL = "INSERT INTO FieldTemplatesUse(FID, TemplateAK) " _
& "VALUES(""" & FieldName & """, """ & Dialog & """)"
DoCmd.RunSQL (insertSQL)
End If
Next i
End If
rs.MoveNext
Loop
End Sub
right now on the line that says
If TestArray(i) <> "" Then
creates an error ""
If anyone can help, I'd really appreciate it!
Another Edit:
Parfait figured out my issue. I'm posting the final code I am using, in case it helps someone else! p.s. I added a condition to check if the dlookup is successful, and trap failures in a failures table. That way I can check those out afterward.
Private Sub RunParse_Click()
Dim db As DAO.Database
Dim rs As Recordset
Set db = CurrentDb()
Dim sqlStr, insertSQL, arrayVal As String
Dim TestArray As Variant
Dim Options As String
Dim Dialog As String
Dim FieldName As Long
Dim i As Integer
sqlStr = "SELECT [Master Fields].Options,[Master Fields].[Variable Name] FROM [Master Fields] WHERE ((([Master Fields].[Variable Type])='dialog'));"
Set rs = db.OpenRecordset(sqlStr)
rs.MoveLast
rs.MoveFirst
Do While Not rs.EOF
Options = rs.Fields(0)
Dialog = rs.Fields(1)
If InStr(Options, ";") Then
TestArray = Split(Options, ";")
For i = 0 To UBound(TestArray) - LBound(TestArray)
If TestArray(i) <> "" Then
arrayVal = TestArray(i)
If Not (IsNull(DLookup("ID", "Master Fields", "[Variable Name] = " & "'" & arrayVal & "'"))) Then
FieldName = DLookup("ID", "Master Fields", "[Variable Name] = " & "'" & arrayVal & "'")
insertSQL = "INSERT INTO FieldTemplatesUse(FID, TemplateAK) " _
& "VALUES(""" & FieldName & """, """ & Dialog & """)"
DoCmd.RunSQL (insertSQL)
'MsgBox "Adding ID = " & FieldName & "for Dialog: " & Dialog & "Now"
Else
insertSQL = "INSERT INTO tblFieldsNotFound(Dialog, FieldNotFound) " _
& "VALUES(""" & Dialog & """, """ & arrayVal & """)"
DoCmd.RunSQL (insertSQL)
End If
End If
Next i
End If
rs.MoveNext
Loop
MsgBox "All Done!"
End Sub

De-Replicate an Access Database

I have an Access database that I need to reverse engineer into a website (app & data).
I just tried opening it with Outlook 2013 but I get an error that the database has replication enabled and it created with an earlier version of Access (something to that affect).
I assume it's just the replication that's the issue. Is there a way to remove the replication so I can poen it in Access 2013?
So it's not an easy job to unreplicate a database.
First I found WV Mitchell's VBA script that copies your tables into a new database:
http://www.wvmitchell.com/tips/Removing%20Access%20Replication.htm
That doesn't copy the Primary Keys or the Relationships, so I wrote a few quick and dirty VBA scripts to help with that.
Step 1: In the MakeOneTable function from the above script, I added this (above the db.Close line):
Dim td As TableDef
Dim idxLoop As Index
Set td = db.TableDefs(TableName)
For Each idxLoop In td.Indexes
If idxLoop.Primary = True Then
Dim colnames As String
colnames = idxLoop.Fields
colnames = Replace(colnames, ";+", "],[")
colnames = Replace(colnames, "+", "[")
colnames = colnames & "]"
Debug.Print "DoCmd.RunSQL ""CREATE INDEX [PrimaryKey] ON [" & TableName & "] (" & colnames & ") With Primary;"""
Exit For
End If
Next idxLoop
That will output to the Debug (Immediate) Window some VBA code for creating the primary keys (as well as creating the new database and exporting the data to it - MV Mitchell's code). Copy that VBA code, put it into a module/macro in the new database, and run it - and it should create the Primary Keys.
Step 2: In the Old (replicated) database, run this VBA code, which will generate some more VBA code for creating the relationships:
Sub GenerateRelationshipCode()
Dim db As DAO.Database
Set db = CurrentDb()
Dim rs As DAO.Recordset
Set rs = db.OpenRecordset("SELECT DISTINCT szRelationship,szObject,szReferencedObject FROM MSysRelationships ORDER BY szObject,szReferencedObject")
rs.MoveFirst
Do While Not rs.EOF
Dim rsFields As DAO.Recordset
Set rsFields = db.OpenRecordset("SELECT * FROM MSysRelationships WHERE szRelationship = '" & Replace(rs.Fields(0), "'", "''") & "'")
Dim PKFields As String, PKTable As String, FKFields As String, FKTable As String
PKFields = "": PKTable = "": FKFields = "": FKTable = ""
Do While Not rsFields.EOF
PKFields = PKFields & rsFields("szReferencedColumn") & ","
PKTable = rsFields("szReferencedObject")
FKFields = FKFields & rsFields("szColumn") & ","
FKTable = rsFields("szObject")
rsFields.MoveNext
Loop
PKFields = Left(PKFields, Len(PKFields) - 1)
FKFields = Left(FKFields, Len(FKFields) - 1)
Debug.Print "Call AddRelationship(""" & rs.Fields(0) & """, """ & FKTable & """, """ & FKFields & """, """ & PKTable & """, """ & PKFields & """)"
rs.MoveNext
Loop
Set db = Nothing
End Sub
You will need to run the output from the above against the new database, but you will also need this function:
Public Sub AddRelationship(Name As String, FKTable As String, FKFields As String, PKTable As String, PKFields As String)
Dim strSQL As String
Dim db As DAO.Database
Set db = CurrentDb()
Name = "FK_" & Replace(FKTable, " ", "") & "_" & Replace(PKTable, " ", "") 'only enable this line if there aren't multiple relationships between same 2 tables
strSQL = "ALTER TABLE [" & FKTable & "] " & _
" add constraint " & Name & " foreign key (" & FKFields & ") " & _
" references [" & PKTable & "](" & PKFields & ") "
db.Execute strSQL, dbFailOnError
Set db = Nothing
End Sub
Run the generated VBA code in a module with the above function, and it should rebuild your relationships in the new database.
Note this code is quick & dirty so might need some bug fixes for your database/data.

Updating Access Database from Excel Worksheet Data

I extract data from my Access database into an Excel worksheet using a macro. I first open a connection to the database, define my sql statement in a string var and then dump that data in a recordset:
Dim db As Database
Dim rs As RecordSet
Dim sql As String
Dim dbLocation As String
dbLocation = ThisWorkbook.Path & "\database\data.accdb"
Set db = OpenDatabase(dbLocation)
sql = "Select * FROM [Master Table]"
Set rs = db.OpenRecordSet(sql, dbOpenSnapshot)
If Not rs.EOF Then
Worksheets("Sheet1").Range("A1").CopyFromRecordset rs
End If
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
This works perfectly. I distribute this to some people and ask them to update fields. I then need to update the Access data with data that is passed back. The simple thing in terms of design is that the extracted excel data mirrors the access db in structure so the update query should be simple. Also there is a primary key, so I would just need to map on that field.
Any ideas how this can be done? Can I load the whole excel datasheet into a recordset and run some snazzy update query?
You need to loop over rows on sheet 1, and for each row make sql string that looks like:
"update [Master table] set
TableField1 = " & Range(Row, Col1).Value & ","
TableField2 = " & Range(Row, Col2).Value & ","
...
where IDTableField = " & Range(Row, IDColNum).Value
and then do
db.Execute thatString
PS: There are may be mistakes in my syntax. And you need to convert cell values to strings when making string.
An extension of shibormot's solution using DAO:
Set objConnection = CreateObject("DAO.DBEngine.36")
Set db = objConnection.OpenDatabase(strDBPath, blnExclusive, blnReadOnly, strPassword)
For Each row In Range("A1:C3").Cells
strSQL = "UPDATE table SET "
strSQL = strSQL & "Field1 = " & Chr(34) & row.Cells(1) & Chr(34) & ","
strSQL = strSQL & "Field2 = " & Chr(34) & row.Cells(2) & Chr(34) & ","
strSQL = strSQL & "Field3 = " & Chr(34) & row.Cells(3) & Chr(34)
Db.Execute
Next
Threw in the chr(34) for string data

Is it possible to "sync" two tables in different Access files using VBA?

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