VBA : Scripting in MS ACCESS to run multiple Queries consecutively

It can be necessary for many reasons to want to run queries consecutively without supervision. This was particularly necessary for me when I was doing a system transfer project. The production Oracle server was being used on a daily basis and we needed to transfer all the information across to a new system which initially was being run in parallel. Over several months myself and a colleague built up 500 queries that pulled out all of this information and placed it in a staging access database that was then loaded into a new Oracle backend. The queries didn’t just export the data they did a significant amount of transformation as the source and target databases had different structures. By being able to script the queries we had created we could take the information out of the source database at short notice. Generally in 2 hours. As we progressed further through the project we would get into the habit of running script of queries periodically as we saw fit.

Generally we did this by creating user defined functions that scripted the queries we wished to run.
This is an example of the format that we used for these functions.
DoCmd.SetWarnings False is important as without it you have to stay at your computer to hit annoying OK buttons

Public Function RunQueries()

DoCmd.SetWarnings False
DoCmd.OpenQuery ("Query01")
DoCmd.OpenQuery ("Query02")
DoCmd.SetWarnings True
MsgBox "Finished"

End Function

VBA Code : Run a Function and Link Functions together ( or Scripting in MS Access)

MS Access can be used as an extremely powerful scripting environment that can tie together manipulation of data using VBA functions and SQL.

Before you can really use this power however you need to know three things
1.Where to put functions
2.How to run them
3.How to string multiple functions together (or script them)

Here is a simple user defined function that we will use for demonstration purposes.

Public Function DisplayCompleteTime()
Dim X As Date
X = Now()
MsgBox "Finished Function at " & X
End Function

1.Where to put Functions?
There is more than one place to place functions. They can be placed in forms, in modules or in class modules. Here I describe how to place them in a module in a MS Access 2003 database called ScriptDatabase the menu path of how you get to the module section varies from Access version to access version but they are very very similar.

Open the Database window

Click on Module and then Click on New a new modal pop up screen should appear

Take your Function and place it in the module
I like to type Option Explicit at the start of every function.

Using the menus save the module – I saved my module prior to taking the snapshot of the screen – if you haven’t done this it will automatically ask you to save the module on exit.

2. Running a Function
OK so you have a function in a module which is saved but you want to run it.
Go back into the module with your function and navigate the menus View / Immediate Window.

How the immediate window displays is a bit unpredictable sometimes it comes up as a modal sometimes it is placed within the module screen and squeezes other sections out either way is should be a blank area with flashing cursor at the beginning.

Now to run your function or functions within the Immediate Window type a question mark followed by the function you wish to run in our case DisplayCompletionTime then simply press return

?DisplayCompleteTime

on return you should get something like this

Congratulations you can now run any function from the immediate window#

3. How to run multiple Functions consecutively

Do same as step 1 but this time type in the following

Public Function MultipleLinkedFunctions()

Call DisplayCompleteTime
Call DisplayCompleteTime
Call DisplayCompleteTime

End Function

as per 2 open the immediate window and then type in ?MultipleLinkedFunctions and press return.

Hitting return will display the complete time this is run three times because you are using a function that asks the function to display three times.

Congratulations you have just run a script in MS Access.

Upload Shape Files into SQL Azure using OGR2OGR – Explanation of MS SQL Azure Connection String to be placed within OGR2OGR Command Line

Lets say you have a SQL Azure Server with the following parameters

SQL Azure Instance : azureinstance1
Database name within Instance : TouristDB1
Your User Name is : tom
Password is : Edinburgh

The SQLAzure connection string would be
MSSQL:Server=tcp:azureinstance1.database.windows.net;Database=TouristDB1;
Uid=tom@azureinstance1.database.windows.net;Pwd=Edinburgh;

and the full OGR2OGR to import Command Line Instruction for a shape file called Monuments.shp would be..

ogr2ogr -overwrite -f MSSQLSpatial "MSSQL:Server=tcp:azureinstance1.database.windows.net;Database=TouristDB1;
Uid=tom@azureinstance1.database.windows.net;Pwd=Edinburgh;" "C:\Monuments.shp"

VBA Function to Create Table of Import strings using OGR2OGR targeting a SQL Server

Do you have many shape files you wish to import into a local SQL Server Database so that you can display them in QGIS or serve them on Geoserver?
Here’s a short function I wrote that will take a table called T0001OpenStreetMapLayers with fields PKID/Name/Directory/Type/Flag – and produce OGR strings that can then be used to load them into a local SQL Server / SQL Express or SQL Azure

For this to be useful you will need
A version of QGIS
A local SQL Server copy (in this case SQL Server Express)
A database within your copy called OpenStreetMap
All shape files in the same directory
You will also need to figure out how to get all those shape files into the table T0001OpenStreetMapLayers table
A starting database with 2 tables
T0001OpenStreetMapLayers with populated fields PKID/Name/Directory/Type/Flag
T0002OGRStrings blank table with fields PKID/CommandLine – This is where all the Command Line Strings will be stored

Public Function CreateTableOGR2OGRString()

Dim rs1 As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim db As DAO.Database
Dim O2O As String
Dim LCounter As Integer
Dim strQuote As String
Set db = CurrentDb
strQuote = Chr$(34)


LCounter = 1
While LCounter < 3000
LCounter = LCounter < 3000

Set rs1 = CurrentDb.OpenRecordset("SELECT T0001OpenStreetMapLayers.PKID, T0001OpenStreetMapLayers.Name, T0001OpenStreetMapLayers.Directory, T0001OpenStreetMapLayers.Type, T0001OpenStreetMapLayers.Flag FROM T0001OpenStreetMapLayers WHERE (((T0001OpenStreetMapLayers.Type)=1) AND ((T0001OpenStreetMapLayers.Flag)=0 Or (T0001OpenStreetMapLayers.Flag) Is Null));")
O2O = "ogr2ogr -append -f MSSQLSpatial " & strQuote & "MSSQL:server=DESKTOP-JECT7QO\SQLEXPRESS;database=OpenStreetMap;trusted_connection=yes" & strQuote & " " & strQuote & rs1!Directory & rs1!Name & ".shp" & strQuote & ""


rs1.Edit
rs1!Flag = 1
rs1.Update
rs1.MoveNext
rs1.Close

Set rs2 = CurrentDb.OpenRecordset("T0002OGRStrings")
With rs2
.AddNew
rs2!CommandLine = O2O
rs2.Update
rs2.Close
End With
Wend
End Function

For SQL Azure target databases replace the yellow connection string with something resembling;

MSSQL:Server=tcp:azureinstance1.database.windows.net;Database=TouristDB1;
Uid=tom@azureinstance1.database.windows.net;Pwd=Edinburgh;

There are multiple methods of finding the name of your SQL Instance – Ignoring the fact that you won’t be able to connect to it if you don’t know it – Within SSMS you can right click on the instance and look to properties but the name itself is usually in the instance path of SSMS as well.

MS SQL Azure to MS Access – Using VBA to Dump Azure Tables into MS Access Tables

The first thing you need to get sorted when moving to SQL Azure is having the ability to get your information out and safe if needs be. When experimenting with MS Azure and for applications that don’t have sensitive information it is nice to have that information available in an easily accessible format. Here are a series of functions that will copy Azure Tables linked to database into local MS Access tables with the prefix ZCOPY.

The starting point in this should be an MS Access database that should be linked to your SQL Azure Database. Only those tables that are linked will be copied. Remember the 2GB limit on Access.

I think I have got all the functions here that are required to make it work and include the complete module at the bottom but first I will breakdown the modules and list describe what each of the functions do.

First create a table to store the list of tables in the Azure Database

Public Function CreateTableT0001AzureTablesGlobal()
 
     Dim dbs As Database
     Set dbs = CurrentDb
 
        dbs.Execute "CREATE TABLE T0001AzureTablesGlobal " _
        & "(PKID AUTOINCREMENT, " _
        & "AzureTableName CHAR CONSTRAINT PKID " _
        & "PRIMARY KEY);"
   
End Function

Now Create a Function that will hold the SQL that takes the tables and makes them locally.

Public Function CreateTableT0002SQL()
 
     Dim dbs As Database
     Set dbs = CurrentDb
 
        dbs.Execute "CREATE TABLE T0002SQL " _
        & "(PKID AUTOINCREMENT, " _
        & "SQL MEMO CONSTRAINT PKID " _
        & "PRIMARY KEY);"
 
   
End Function

A function that allows for stepping through the table

Public Function AddByteColumn(TblName As String, FieldName As String)
'Just use byte data type as only going to use this for a flag

DoCmd.RunSQL "AlTER TABLE [" & TblName & "] ADD COLUMN " & FieldName & " BYTE;"

End Function

Step through the Linked Azure Tables and poupulate table T001 with their names

Public Function CreateandPopulateListofDBOTableNames()

'These will typically be the names of the SQL Server tables this should work both with SQL Server and SQL Azure

Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rstList As DAO.Recordset

'Call CreateTableT0001AzureTablesGlobal

Set rstList = CurrentDb.OpenRecordset("T0001AzureTablesGlobal")
Set db = CurrentDb

For Each tdf In db.TableDefs
    ' ignore system and temporary tables and tables starting with T - personal choice option
    If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "T*") Then
       With rstList
       .AddNew
       rstList!AzureTableName = tdf.Name
       rstList.Update
      End With
    End If
    
Next

Set tdf = Nothing
Set db = Nothing

End Function

The next function is required to strip out additional spaces in names

Public Function FindXReplaceY(FixTable As String, FixColumn As String, X As String, Y As String) As Variant

Dim strSQL As String

strSQL = "UPDATE [" & FixTable & "] SET [" & FixTable & "].[" & FixColumn & "] = REPLACE([" & FixColumn & "]," & Chr$(34) & X & Chr$(34) & "," & Chr$(34) & Y & """);"

DoCmd.RunSQL strSQL

End Function

We can now write the VBA that will write the make table SQL that once run will put one make table query into the maketableSQL table for each Azure table.

Public Function CreateMakeTableSQL()

On Error GoTo Err_CreateMakeTableSQL
Dim rstSQL As DAO.Recordset
Dim rstSQLx As DAO.Recordset
Dim dbc As DAO.Database
Dim SQLStringAdd As String
Dim LCounter As Long

Set dbc = CurrentDb

LCounter = 1
While LCounter < 9000
LCounter = LCounter + 1
Set rstSQL = CurrentDb.OpenRecordset("SELECT T0001AzureTablesGlobal.PKID, T0001AzureTablesGlobal.AzureTableName, T0001AzureTablesGlobal.XFLag1 FROM T0001AzureTablesGlobal WHERE (((T0001AzureTablesGlobal.XFLag1) Is Null));")

SQLStringAdd = "SELECT * INTO COPY" & rstSQL!AzureTableName & " FROM " & rstSQL!AzureTableName & ";"

Set rstSQLx = CurrentDb.OpenRecordset("T0002SQL")
With rstSQLx
.AddNew
rstSQLx!SQL = SQLStringAdd
rstSQLx.Update
rstSQLx.Close
End With

With rstSQL
rstSQL.Edit
rstSQL!XFLag1 = 1
rstSQL.Update
rstSQL.MoveNext
rstSQL.Close
End With

Wend

Exit_CreateMakeTableSQL:
    Exit Function

Err_CreateMakeTableSQL:
Select Case Err.Number
 Case 3021
   Resume Exit_CreateMakeTableSQL
  Case Else
  Resume Exit_CreateMakeTableSQL
  End Select
 
End Function

And finally Run all the queries

Public Function RunQueriesFromTable2(SQLSource As String)

DoCmd.SetWarnings False

Dim StartTime As Date
Dim EndTime As Date
Dim rstZ As DAO.Recordset
Dim strSQL2 As String

StartTime = Now()

Set rstZ = CurrentDb.OpenRecordset(SQLSource)

Do Until rstZ.EOF

strSQL2 = rstZ!SQL
DoCmd.RunSQL strSQL2
rstZ.MoveNext

Loop

DoCmd.SetWarnings True

EndTime = Now()

MsgBox "Finished ALL SQL queries! Process started at " & StartTime & " and finished at " & EndTime

End Function

And a script to pull all of this together

Public Function GetAzureScript()

DoCmd.SetWarnings False
Call CreateTableT0001AzureTablesGlobal
Call CreateandPopulateListofDBOTableNames
Call FindXReplaceY("T0001AzureTablesGlobal", "AzureTablename", " ", "")
Call FindXReplaceY("T0001AzureTablesGlobal", "AzureTablename", Chr(10), "")
Call AddByteColumn("T0001AzureTablesGlobal", "XFLag1")
Call CreateTableT0002SQL
Call CreateMakeTableSQL
Call FindXReplaceY("T0002SQL", "SQL", " ", "")
Call FindXReplaceY("T0002SQL", "SQL", Chr(10), "")
Call FindXReplaceY("T0002SQL", "SQL", "SELECT*INTOCOPY", "SELECT * INTO ZCOPY")
Call FindXReplaceY("T0002SQL", "SQL", "FROM", " FROM ")
Call RunQueriesFromTable("T0002SQL")
DoCmd.SetWarnings True

End Function

The complete module

Option Compare Database
Option Explicit

Public Function GetAzureScript()

DoCmd.SetWarnings False
Call CreateTableT0001AzureTablesGlobal
Call CreateandPopulateListofDBOTableNames
Call FindXReplaceY("T0001AzureTablesGlobal", "AzureTablename", " ", "")
Call FindXReplaceY("T0001AzureTablesGlobal", "AzureTablename", Chr(10), "")
Call AddByteColumn("T0001AzureTablesGlobal", "XFLag1")
Call CreateTableT0002SQL
Call CreateMakeTableSQL
Call FindXReplaceY("T0002SQL", "SQL", " ", "")
Call FindXReplaceY("T0002SQL", "SQL", Chr(10), "")
Call FindXReplaceY("T0002SQL", "SQL", "SELECT*INTOCOPY", "SELECT * INTO ZCOPY")
Call FindXReplaceY("T0002SQL", "SQL", "FROM", " FROM ")
Call RunQueriesFromTable2("T0002SQL")
DoCmd.SetWarnings True

End Function

Public Function CreateandPopulateListofDBOTableNames()

'These will typically be the names of the SQL Server tables this should work both with SQL Server and SQL Azure

Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim rstList As DAO.Recordset

'Call CreateTableT0001AzureTablesGlobal

Set rstList = CurrentDb.OpenRecordset("T0001AzureTablesGlobal")
Set db = CurrentDb

For Each tdf In db.TableDefs
    ' ignore system and temporary tables and tables starting with T - personal choice option
    If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "T*") Then
       With rstList
       .AddNew
       rstList!AzureTableName = tdf.Name
       rstList.Update
      End With
    End If
    
Next

Set tdf = Nothing
Set db = Nothing

End Function

Public Function FindXReplaceY(FixTable As String, FixColumn As String, X As String, Y As String) As Variant

Dim strSQL As String

strSQL = "UPDATE [" & FixTable & "] SET [" & FixTable & "].[" & FixColumn & "] = REPLACE([" & FixColumn & "]," & Chr$(34) & X & Chr$(34) & "," & Chr$(34) & Y & """);"

DoCmd.RunSQL strSQL

End Function

Public Function CreateTableT0001AzureTablesGlobal()
 
     Dim dbs As Database
     Set dbs = CurrentDb
 
        dbs.Execute "CREATE TABLE T0001AzureTablesGlobal " _
        & "(PKID AUTOINCREMENT, " _
        & "AzureTableName CHAR CONSTRAINT PKID " _
        & "PRIMARY KEY);"
 
   
End Function

Public Function CreateTableT0002SQL()
 
     Dim dbs As Database
     Set dbs = CurrentDb
 
        dbs.Execute "CREATE TABLE T0002SQL " _
        & "(PKID AUTOINCREMENT, " _
        & "SQL MEMO CONSTRAINT PKID " _
        & "PRIMARY KEY);"
 
   
End Function

Public Function AddByteColumn(TblName As String, FieldName As String)
'Just use byte data type as only going to use this for a flag

DoCmd.RunSQL "AlTER TABLE [" & TblName & "] ADD COLUMN " & FieldName & " BYTE;"

End Function

Public Function CreateMakeTableSQL()

On Error GoTo Err_CreateMakeTableSQL
Dim rstSQL As DAO.Recordset
Dim rstSQLx As DAO.Recordset
Dim dbc As DAO.Database
Dim SQLStringAdd As String
Dim LCounter As Long

Set dbc = CurrentDb

LCounter = 1
While LCounter < 9000
LCounter = LCounter + 1
Set rstSQL = CurrentDb.OpenRecordset("SELECT T0001AzureTablesGlobal.PKID, T0001AzureTablesGlobal.AzureTableName, T0001AzureTablesGlobal.XFLag1 FROM T0001AzureTablesGlobal WHERE (((T0001AzureTablesGlobal.XFLag1) Is Null));")
SQLStringAdd = "SELECT * INTO COPY" & rstSQL!AzureTableName & " FROM " & rstSQL!AzureTableName & ";"

Set rstSQLx = CurrentDb.OpenRecordset("T0002SQL")
With rstSQLx
.AddNew
rstSQLx!SQL = SQLStringAdd
rstSQLx.Update
rstSQLx.Close
End With

With rstSQL
rstSQL.Edit
rstSQL!XFLag1 = 1
rstSQL.Update
rstSQL.MoveNext
rstSQL.Close
End With

Wend

Exit_CreateMakeTableSQL:
    Exit Function

Err_CreateMakeTableSQL:
Select Case Err.Number
 Case 3021
   Resume Exit_CreateMakeTableSQL
  Case Else
  Resume Exit_CreateMakeTableSQL
  End Select
 
End Function

Public Function RunQueriesFromTable2(SQLSource As String)

DoCmd.SetWarnings False

Dim StartTime As Date
Dim EndTime As Date
Dim rstZ As DAO.Recordset
Dim strSQL2 As String

StartTime = Now()

Set rstZ = CurrentDb.OpenRecordset(SQLSource)

Do Until rstZ.EOF

strSQL2 = rstZ!SQL
DoCmd.RunSQL strSQL2
rstZ.MoveNext

Loop

DoCmd.SetWarnings True

EndTime = Now()

MsgBox "Finished ALL SQL queries! Process started at " & StartTime & " and finished at " & EndTime

End Function

MS Access VBA Function (Part 5) – Run SQL Queries from a table

Clearly there is a problem with generating 66,000 queries and ramming each of them into the Query Database Window. Yes you got it, an MS Access database can only hold circa 32,000 objects (32,768 to be exact). I had been writing the query definitions to the system query definition table and this was making an elegant but pointless alphabetically ordered telephone directory out of the query database window before bombing out at the database limit. Defining programmatically more and more queries to be written to the query definition window was a revolution that ended as quickly as it had begun. A maximum limit I had previously never hit in all of the databases I had ever created, I hit in 1 hour. But how to run query lists longer than 32,000? Do I really need to break everything into separate databases with each complying with the 32,000 object limit? I felt there must be a better solution.

Then it hit me – I shouldn’t write the queries to the database window. Keep the queries in a table and call the queries from a function. That way the queries aren’t considered as objects in your natural sense to MSAccess but are run as queries when triggered from VBA. That way the limit on objects in a single database is the limit of data I can hold in a table. By linking to other tables that limit may even approach 2GB. That’s enough queries to keep me going for quite some time.

This is what I came up with

Be warned running thousands of queries takes time you might need to run this overnight or over several days hence why I have included a start datetime and end datetime to be shown in the message box on completion it is interesting to see how long 100s or 1000s of queries take to run. My queries can now potentially perform trillions of calculations all unattended by me.

Now I just want to run lots and lots of queries!!!

Public Function RunQueriesFromTable(SQLSource As String)

DoCmd.SetWarnings False

Dim StartTime As Date
Dim EndTime As Date
Dim rstZ As DAO.Recordset
Dim strSQL As String

StartTime = Now()

Set rstZ = CurrentDb.OpenRecordset(SQLSource)

Do Until rstZ.EOF

strSQL = rstZ!SQL
DoCmd.RunSQL strSQL
rstZ.MoveNext

Loop

DoCmd.SetWarnings True

EndTime = Now()

MsgBox "Finished ALL SQL update queries! Process started at " & StartTime & " and finished at " & EndTime

End Function

MS Access VBA Function (Part 4) – Write queries to a table

This is really great for address matching – take a clean source of information and create a set of update queries looking for strings that will be run on a table with less than clean data.

Public Function CreateTableofSQL()

Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim db As DAO.Database
Dim SQLString As String
Dim LCounter As Long
Set db = CurrentDb


LCounter = 1
While LCounter < 3000</code>
<code>LCounter = LCounter + 1</code>


<code>Set rst1 = CurrentDb.OpenRecordset("SELECT TestTest.XStreetname, TestTest.XFlag, TestTest.Length, TestTest.XStreetname2, TestTest.XFlag FROM TestTest WHERE (((TestTest.XFlag) Is Null Or (TestTest.XFlag) = 0)) ORDER BY TestTest.Length, TestTest.XStreetname2;")</code>

<code>SQLString = "UPDATE T002BCAPR SET T002BCAPR.XStreetNameQuery = '" & rst1!XStreetname2 & "' WHERE (((T002BCAPR.LOCADDRESS1) LIKE '*" & rst1!XStreetname2 & "*'));"</code>

<code>
rst1.Edit
rst1!XFlag = 1
rst1.Update
rst1.MoveNext
rst1.Close

Set rst2 = CurrentDb.OpenRecordset("T008SQL")
With rst2
.AddNew
rst2!SQL = SQLString
rst2.Update
rst2.Close
End With
Wend


End Function

MS Access VBA Function (Part 3) Address Matching – Find X Replace Y

A useful function for replacing characters or strings in a single field. This can be used in advance of address matching to increase the chances of getting matches in fields that have been collected through a UI with little or no validation.

Function FindXReplaceY(FixTable As String, FixColumn As String, X As String, Y As String) As Variant

    Dim strSQL As String

    strSQL = "UPDATE [" & FixTable & "] SET [" & FixTable & "].[" & FixColumn & "] = REPLACE([" & FixColumn & "]," & Chr$(34) & X & Chr$(34) & "," & Chr$(34) & Y & """);"
    
    DoCmd.RunSQL strSQL
    

End Function

And this is an example script that calls the above function to replace some special characters

Public Function RunFindXReplaceY()

DoCmd.SetWarnings False

    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "'", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "@", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "~", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "#", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "!", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "£", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "$", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "^", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "&", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "*", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "(", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", ")", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "-", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "+", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "=", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "?", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "|", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "\", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "/", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "{", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "}", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "[", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "]", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "`", " ")
    Call FindXReplaceY("TableNameVariable", "FieldNameVariable", "¬", " ")

DoCmd.SetWarnings True

End Function

MS Access VBA Functions (Part 2) Address Matching – UK Postcode String Finder

UK Postcode extractor

Function GetPostCode(Optional AddressText As Variant) As String
Dim AddrTextLength As Integer, TempText As String, TempPicture As String
Dim PostCodePics(10) As String, PictureItemNum As Integer
Dim n As Integer, x As Integer

GetPostCode = "" ' default response if no postcode detected
If IsNull(AddressText) Then
Exit Function
End If

PostCodePics(1) = "XXNSNXX" ' alternative formats of postcodes
PostCodePics(2) = "XXNNSNXX" ' where X = alpha, S = space
PostCodePics(3) = "XNNSNXX" ' and N = numeric
PostCodePics(4) = "XNSNXX"
PostCodePics(5) = "XXNNXX"
PostCodePics(6) = "XXNNNXX"
PostCodePics(7) = "XNNNXX"
PostCodePics(8) = "XNNXX"
PostCodePics(9) = "XXNXNXX"
PostCodePics(10) = "XXNXSNXX"

AddrTextLength = Len(AddressText)

If AddrTextLength < 5 Then
Exit Function
End If
If AddrTextLength <= 9 Then
TempText = Trim(AddressText)
Else
TempText = Trim(Right(AddressText, 9))
End If

PictureItemNum = 0
TempPicture = "" ' build a picture of the format of current text
For n = 1 To Len(TempText) ' detect the type of each character
x = InStr(1, "1234567890 ", Mid(TempText, n, 1))
If x > 0 And x < 11 Then TempPicture = TempPicture & "N"
If x = 11 Then TempPicture = TempPicture & "S"
If x = 0 Then TempPicture = TempPicture & "X"
Next

For n = 1 To 10 ' compare the format of the current text
x = Len(PostCodePics(n)) ' against each of the post code pictures
If Len(TempPicture) >= x Then
If Right(TempPicture, x) = PostCodePics(n) Then
PictureItemNum = n
GetPostCode = UCase(Right(TempText, x))
Exit For
End If
End If
Next

If PictureItemNum > 4 And PictureItemNum < 10 Then ' insert space in the middle if not present
GetPostCode = Left(GetPostCode, Len(GetPostCode) - 3) & " " & Right(GetPostCode, 3)
End If

End Function

MS Access VBA Functions (Part 1) Address Matching – Add and Drop Fields

Here are a series of Functions that can be used to help in matching addresses between a dataset that is good (eg Assessors Street File) and a dataset that could be improved – eg a Customer Relationship Management System.

ADD and DROP Fields

Function AddCharColumn(TblName As String, FieldName As String)

DoCmd.RunSQL "AlTER TABLE [" & TblName & "] ADD COLUMN " & FieldName & " CHAR(100);"

End Function

Function AddIntegerColumn(TblName As String, FieldName As String)

DoCmd.RunSQL "AlTER TABLE [" & TblName & "] ADD COLUMN " & FieldName & " INTEGER;"

End Function

Function AddDoubleColumn(TblName As String, FieldName As String)

DoCmd.RunSQL "AlTER TABLE [" & TblName & "] ADD COLUMN " & FieldName & " Double;"

End Function

Function DropColumn(TblName As String, FieldName As String) As Variant

DoCmd.RunSQL "ALTER TABLE [" & TblName & "] DROP COLUMN " & FieldName & ";"

End Function

MS Access front end – MS SQL Azure back end Link to Configuration Set UP FMS Group

This is an excellent article on linking MS Access to SQL Azure – which is just great if you are wanting to use your VBA skills direct on your SQL Database.

FMS Professional Solutions Group – Luke Chung MVP article

It should be noted that the Primary Key will need to be set to Integer in the SQL Database rather than Big Int otherwise it will appear as #DELETED# when you go in and view the data. This may not be an issue going forward for some users of Office 365 Access 2016 as Microsoft are introducing support for Big Int in MS Access. Congratulations to Microsoft on that small but important change.

MS Access VBA Function – create UID starting at prescribed number

Useful function if you are taking two tables with overlapping identity key to be placed in a table that will have a further child record and you wish to separate the new keys.

Public Function WriteUID(LCounter As Long) As Long
 
Dim rstC As DAO.Recordset
Dim LCountStart As Double
 
LCountStart = LCounter
 
Set rstC = CurrentDb.OpenRecordset("TABLEREQUIRINGUNIQUEID")
 
Do Until rstC.EOF = True
 
rstC.Edit
rstC!UID = LCounter
rstC.Update
 
LCounter = LCounter + 1
 
rstC.MoveNext
 
Loop

MsgBox "Finished UNIQUEID write"
 
End Function

Linking to SQL Server / Oracle – don’t skip the set key field on linking

After writing Update queries with multiple joins on linked Oracle Databases I was receiving an error on running particular update queries on linked tables that had no Primary Key identified.
On linking the tables I had been asked to identify a field with a unique value. Not thinking I had passed on this and initially this didn’t seem to be an issue. Subsequently I identified that the error associated with the update queries originated from this lack of key identification. Re-linking required tables and ensuring that I identified a unique key allowed for these queries to be processed. This of course is because Access is wanting to use the unique key to identify the field for update.

The message

Operation must use an updateable query.

Just one to be mindful of if you are linking to enterprise grade backend databases.

MS Access VBA Function – Loop through Query Objects and write SQL to Table

Continuing the theme of tools that assist the use of MS Access as a platform for transferring data between systems. Here is a small function that will allow you to write the pure SQL syntax of all queries in a database to a table. I personally used this in a system transfer project. The business had given us something called a field mapping plan that identified the table and fields in one system and where they were to be migrated in the other system. Having written the queries I then wanted to go back through and reconcile the original mapping to the SQL to ensure that absolutely every field had been taken across. Writing the SQL into a table allows for table and field combinations to be methodically searched. Quite useful.

Create a table called T001SQLCollection with at least 2 fields – QueryName and SQL. This is where the recordset writes the SQL to.

This is very much a reverse of the previous post function.

Public Function ListQueries()
 
Dim rstList As DAO.Recordset
 
    Dim i As Integer
        For i = 0 To CurrentDb.QueryDefs.Count - 1
        Set rstList = CurrentDb.OpenRecordset("T001SQLCollection")
        With rstList
            .AddNew
            rstList!QueryName = CurrentDb.QueryDefs(i).Name
            rstList!SQL = CurrentDb.QueryDefs(i).SQL
            rstList.Update
        End With
    Next i
   
    rstList.Close   
 
MsgBox "Finished"
 
End Function

MS Access VBA Function – Automated Multiple Query Object Creation from previously created table of SQL

This completes the task of taking automatically generated SQL previously placed in a table and writes the SQL therein to Query Objects naming them automatically. This has several advantages to cut and paste –

1) Its Lightning Quick
2) Completely consistent naming
3) Cut and Paste can be awkward with the windows
4) Its just fun

To created the NestedIIfs table see this post

MS Access VBA Function – Creating NestedIIFs

This is the post on writing Query Objects directly

MS Access – Automated Single Query Object Creation

It requires that you have a table called T005NestedIIFs
with the populated fields
SQLField
TargTable
TargField

Public Function WriteNIFQueryObjects(LCounter As Long) As String

Dim rstX As DAO.Recordset
Dim QName As String
Dim qdf As Variant
Dim strSQL As String
Dim LCountStart As Long

LCountStart = LCounter

Set rstX = CurrentDb.OpenRecordset("T005NestedIIFs")

Do Until rstX.EOF = True
qdf = rstX!SQLField
QName = "Q" & LCounter & rstX!TargTable & "-" & rstX!Targfield & "-Update"
LCounter = LCounter + 1
Set qdf = CurrentDb.CreateQueryDef(QName, rstX!SQLField)

rstX.MoveNext

Loop

MsgBox "Query objects written to Database numbers starting" & LCountStart

End Function

Run Web Applications in Application Mode : Google Chrome

Turns out the Chrome browser has implemented a really nice display option specifically for websites that have aspects of an application which allows you to remove the clutter at the top of your browser window and makes a website appear in an application like window.

Go to the web page you are interesting in accessing via an application. In my case rounduptheusualsuspects.org

In the top right corner of the web browser next to the address bar you should see three vertical dots – select it to get the drop down menu and then select More Tools and then Create Shortcut.

You should now see the following dialog – ensure the Open as Window is ticked and then hit the Create Button. You can alter its name if you wish.

Now you get a nice icon on your desktop related to the site and what’s more when you open it up there is no address bar and within the taskbar you get the correct icon for the website see below example.

MS Access VBA Function – Create MS Access Query Object – more automation :)

In line with my general theme of automation here’s the framework of a tiny but potentially very useful function to create queries in the current database, linking this in with the loop queries and say something like the nested IF generation function could allow you to take your table of nested queries and write them to the database.

Public Function CreateQuery()

Dim strSQL As String
Dim qdf As Variant

strSQL = "SELECT * FROM T01Contacts"

Set qdf = CurrentDb.CreateQueryDef("GeneratedQuery", strSQL)
MsgBox "GeneratedQuery Created!"

End Function

I like!

Compact Database automatically using this MS Access Function and VB Script

If like me you sometimes need to run multiple SQL statements in MS Access on a regular basis maybe at a particular time some of which are deletes, you will need to find a way to automate regular compacts. Here’s some code scavenged from the interweb that will allow you to do this.

Firstly create the following function in your target MS Access database.

Public Function CompactDatabase()
      Dim vStatusBar As Variant
      DoCmd.SetWarnings False
            
          If FileLen(CurrentDb.Name) > 2000000 Then
              Application.SetOption ("Auto Compact"), 1
              Application.SetOption "Show Status Bar", True
              vStatusBar = SysCmd(acSysCmdSetStatus, "The application will be compacted on close during compaction please do not interrupt")
          Else
              Application.SetOption ("Auto Compact"), 0
          End If
                
End Function

Next open up notepad paste in the following code save it as a txt file and then in explorer edit the suffix to vbs. Then simply double click on the file within explorer to run it. You should see the access database you have identified in the VB script open and then immediately close at which point it carries out the compact. The eagle eyed will have spotted that the above function doesn’t actually perform a compact. All it does is set the compact on close option to True within Access settings. The VB Script then instructs the database to close and Access compacts the database on exit.

set oAccess = createobject("Access.Application")

oAccess.OpenCurrentDatabase "C:Path\TargetDatabaseyouwantCompacted.mdb"
oAccess.visible = true
wscript.sleep 1000
oAccess.Run "CompactDatabase"
oAccess.closecurrentdatabase

set oAccess = nothing

A VB script such as this could be used to remotely run any MS Access function or functions – simply substitute the “CompactDatabase” parameter (or add further run commands) with the name(s) of the function(s) in the database you wish to trigger and then run the VB Script. Be warned the speed at which functions and commands within functions run may vary when called from a vbscript so you may have to use some experimentation to input things like pauses and waits if you start to get very imaginative with the functions run.

MS Access VBA Function – Generate Multiple Nested IIF SQL statements into table with parameter to set Number of Nestings

So in my previous post I had looked at generating single SQL Nested IF statements using MS Access but had highlighted that Access will error out indicating the SQL is too complex should there be more than 13 nested IIFs in a single SQL.

What happens if you have 20 values that you require to be changed.
Answer = you pick 13 and produce one sql statement with 13 nested if statements and another with 7 nested IIF statements.

But damn it,doesn’t that introduces yet another manual step to what was supposed to be automation. Yes it does this is why I wrote this function which allows you to define the number of nestings and will go off and write the appropriate number. And yes I hear you DBAs saying a better way would be to link in the conversion table at the beginning – absolutely but there may be occasions where you can’t link to the required database.

The following iterates through a conversion table and writes the resulting SQL into a table named T005NestedIIFs – it should be noted that the Wend statement is artificially optomised here and if you have an extremely large code conversion table you may need to work on this code to make it dynamically alter the number of WEND statements depending on the BatchFileNo you wish to create and its relation to the number of records in the conversion table. The below code goes to the last record as part of the recordset count and when at 0 will jump to exit so for smaller code conversions its semi-dynamic but for larger files the limit of values converted with be the BatchFileSize * 200 which may or may not be big enough for purpose.

To have this working you will need two tables and knowledge of a third.
T001ConversionCodeTable
This should have 5 fields
OldValue
NewValue
xFlag1
xFlag2
xFlag3

The flag fields only require a single integer value. They are used to record how far through the conversion table you have reached so that when you break from your SQL query you resume at the finish of your former position.

The queries are placed in table
T005NestedIIFs
In which I have created 3 fields
One marked SQLfield
Targtable
Targfield

Public Function CreateTableofSQL(TargetTable As Variant, TargetFieldforUpdate As Variant, BatchSizeNo As Long)
On Error GoTo Err_Writetofile

Dim rst As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim rst3 As DAO.Recordset
Dim rst4 As DAO.Recordset
Dim RecordCount1 As Long
Dim RecordCount2 As Long
Dim LCounter As Integer
Dim SQLString1 As String

LCounter = 1


While LCounter < 200

LCounter = LCounter + 1

SQLString1 = ""

'Three recordsets were testing differing flag fields because order of the integrity of the recordsets were being affected by each other
Set rst2 = CurrentDb.OpenRecordset("SELECT TOP " & BatchSizeNo & " T001CodeConversionTable.PKID, T001CodeConversionTable.OldValue, T001CodeConversionTable.NewValue, T001CodeConversionTable.xFlag2 FROM T001CodeConversionTable WHERE (((T001CodeConversionTable.xFlag2)<>1));")
Set rst3 = CurrentDb.OpenRecordset("SELECT TOP " & BatchSizeNo & " T001CodeConversionTable.PKID, T001CodeConversionTable.OldValue, T001CodeConversionTable.NewValue, T001CodeConversionTable.xFlag3 FROM T001CodeConversionTable WHERE (((T001CodeConversionTable.xFlag3)<>1));")
Set rst = CurrentDb.OpenRecordset("SELECT TOP " & BatchSizeNo & " T001CodeConversionTable.PKID, T001CodeConversionTable.OldValue, T001CodeConversionTable.NewValue, T001CodeConversionTable.xFlag1 FROM T001CodeConversionTable WHERE (((T001CodeConversionTable.xFlag1)<>1));")

'MoveLast required to ensure correct record count at first pass reset to first after this
rst.MoveLast
RecordCount1 = rst.RecordCount
rst.MoveFirst
rst3.MoveLast
RecordCount2 = rst3.RecordCount
rst3.MoveFirst

SQLString1 = SQLString1 & "UPDATE " & TargetTable & " SET " & TargetTable & "." & TargetFieldforUpdate & "="
Do Until rst.EOF = True
rst.Edit
rst!xFlag1 = 1
rst.Update
RecordCount1 = RecordCount1 - 1
SQLString1 = SQLString1 & "IIF((" & TargetTable & "!" & TargetFieldforUpdate & "='" & rst!OldValue & "'),'" & rst!NewValue & "'"
If RecordCount1 = 0 Then
SQLString1 = SQLString1 & " "
Else
SQLString1 = SQLString1 & ","
End If
rst.MoveNext
Loop

rst.Close

Do Until rst2.EOF = True
SQLString1 = SQLString1 & ")"
rst2.Edit
rst2!xFlag2 = 1
rst2.Update
rst2.MoveNext
Loop
SQLString1 = SQLString1 & " WHERE (("

rst2.Close

Do Until rst3.EOF = True
RecordCount2 = RecordCount2 - 1
SQLString1 = SQLString1 & "(" & TargetTable & "!" & TargetFieldforUpdate & ")='" & rst3!OldValue & "'"
rst3.Edit
rst3!xFlag3 = 1
rst3.Update
If RecordCount2 = 0 Then
SQLString1 = SQLString1 & " "
Else
SQLString1 = SQLString1 & " OR "
End If

rst3.MoveNext
Loop

rst3.Close

SQLString1 = SQLString1 & "));"


Set rst4 = CurrentDb.OpenRecordset("T005NestedIIFs")
With rst4
.AddNew
rst4!SQLfield = SQLString1
rst4!Targfield = TargetFieldforUpdate
rst4!Targtable = TargetTable
rst4.Update
rst4.Close
End With

Wend

Exit_WritetoFileError:
 Exit Function

Err_Writetofile:
    If Err.Number = 3021 Then
    MsgBox "All records in Translation table written out no more to translate"
    Else
    MsgBox Err.Description
    End If
 Resume Exit_WritetoFileError

End Function