If you are a Microsoft Access programmer, and would like syntax highlighting, SQL comments and formatting for your SQL queries, please try my Access Add-In: Access SQL Editor!
There is a 14-day trial here, and you may purchase it here. For support, please use our Product Support page.
Most of these VBA functions are to be used with Microsoft Access, but some of them will work in Excel and/or Word. With minimal modification, some can also be used in VB.net.
If something does not work, then I may have forgotten to mention it requires a specific COM Object reference. References are found in the Visual Basic Editor under the Tools->References menu. I believe that all of the COM references I am using on this page are readily available to all installations of Windows with Office.
Using VBA “References” can be exchanged for code that uses the CreateObject statement (which is more portable), but the code produced is less clear, and you cannot use Microsoft IntelliSense with it.
Contents
sprintf() clone for VBA
This uses only the “%s” format (for strings), but it does come in handy quite a bit. You must reference the “Microsoft VBScript Regular Expressions 5.5” COM object in your project (Tools->References).
'Requires a reference to Microsoft VBScript Regular Expressions 5.5 Function Printf(sFormat, ParamArray sArgs()) Dim rx As VBScript_RegExp_55.RegExp Dim mc As VBScript_RegExp_55.MatchCollection Dim m As VBScript_RegExp_55.Match Dim pos, k Set rx = New RegExp rx.Global = True rx.Pattern = "%s" Set mc = rx.Execute(sFormat) pos = 1: k = 0 For k = 0 To min_(mc.Count - 1, UBound(sArgs)) 'For Each m In mc Set m = mc.Item(k) Printf = Printf & Mid(sFormat, pos, m.FirstIndex - pos + 1) & sArgs(k) pos = m.FirstIndex + m.Length + 1 Next Printf = Printf & Mid(sFormat, pos, Len(sFormat)) End Function
Check if a table exists
Function TableExists(sTable) As Boolean TableExists = False If DCount("*", "MSysObjects", "Name='" & sTable & "' And Type=1") > 0 Then TableExists = True End If End Function
Delete a table
Sub Delete_Table(sTable) If TableExists(sTable) Then CurrentDb.TableDefs.Delete sTable End If End Sub
Minimum of two numbers
Function min_(a, b) a = Nz(a, 9E+99) b = Nz(b, 9E+99) min_ = IIf(a < b, a, b) If min_ = 9E+99 Then min_ = Null End Function
Maximum of two numbers
Function max_(a, b) a_ = Nz(a, 0) b_ = Nz(b, 0) max_ = IIf(a_ > b_, a_, b_) If IsNull(a) And IsNull(b) Then max_ = Null End Function
Check if a table has a field in it
Function TableHasField(sTable, sName) Dim f TableHasField = False If DCount("*", "MSysObjects", "Name='" & sTable & "'") > 0 Then With CurrentDb.TableDefs(sTable).OpenRecordset() For Each f In .Fields If f.Name Like sName Then TableHasField = True .Close Exit Function End If Next .Close End With Else 'The ThrowErr function is a custom function. Replace it with 'whatever you want. ThrowErr "TableHasField", "No table " & sTable & " exists." End If End Function
ThrowErr function
Sub ThrowErr(func As String, ErrMsg As String, Optional eObj As ErrObject = Null) MsgBox ErrMsg, vbOKOnly, "Error In " & func & "()" End End Sub
Get or set settings in an Access database
This is a set of functions for an MS-Access database, which allows you to keep settings in it. For example, a start date and an end date for a database run. Make sure there is a “Settings” table in the database with only one row in it. The “SetSetting” function automatically adds fields to the table if they don’t exist.
Also requires the TableHasField function, above.
'Requires a table called "Settings" in the database. 'It should only have 1 row in it. Property Get Settings(sField) CheckSettingsTableExists If TableHasField("Settings", sField) Then Settings = DLookup("[" & sField & "]", "Settings") End If End Property 'Requires a table called "Settings" in the database. 'It should only have 1 row in it. Property Let Settings(sField, sValue) Dim Database As DAO.Database Set Database = CurrentDb() CheckSettingsTableExists If Not TableHasField("Settings", sField) Then Dim oF As DAO.Field, vType Select Case TypeName(sValue) Case "String": vType = dbText Case "Date": vType = dbDate Case "Integer", "Long", "Double": vType = dbDouble Case Else: vType = "String" End Select Set oF = Database.TableDefs("Settings").CreateField(sField, vType, 255) Database.TableDefs("Settings").Fields.Append oF End If With Database.TableDefs("Settings").OpenRecordset .Edit .Fields(sField) = sValue .Update .Close End With End Property 'Create Settings table if it doesn't exist. Sub CheckSettingsTableExists() If Not TableExists("Settings") Then Dim Database As DAO.Database Dim td As DAO.TableDef, f As DAO.Field Set Database = CurrentDb() Set td = Database.CreateTableDef("Settings") Set f = td.CreateField("ID", dbLong) f.Attributes = DAO.dbAutoIncrField td.Fields.Append f Database.TableDefs.Append td With td.OpenRecordset .AddNew 'Add a new record. Settings table should have exactly 1 row. .Update .Close End With End If End Sub
Export an Excel file from an Access Table, with custom formatting
'Export an Excel doc into the current folder. Sub Export_Formatted_Excel_CurDir(ByRef sFilename As String, ByVal sTable As String, ByVal TabName, ByVal Overwrite As Boolean, ParamArray aFormats()) Dim oFS As Scripting.FileSystemObject Set oFS = New Scripting.FileSystemObject sFilename = oFS.GetParentFolderName(CurrentDb.Name) & "" & sFilename Export_Formatted_Excel sFilename, sTable, TabName, True, aFormats Set oFS = Nothing End Sub 'Requires a reference to Micrsoft Excel Object Library and Microsoft Scripting Runtime 'sFileName = FileName to export 'sTable = Table name to export 'Overwrite = Overwrite existing file? 'aFormats_() = Array of formats, each in the format: <Column Letter>;<Excel Numeric Format> Sub Export_Formatted_Excel(ByVal sFilename As String, ByVal sTable As String, ByVal TabName, ByVal Overwrite As Boolean, ParamArray aFormats_()) Dim oApp As Excel.Application Dim oWkb As Excel.Workbook Dim oSh As Excel.Worksheet Dim oFS As Scripting.FileSystemObject Dim DisplayAlerts Dim sFormat, aCurFmt, aFormats On Error GoTo Err_Handler If UBound(aFormats_) >= 0 Then If TypeName(aFormats_(0)) = "Variant()" Then aFormats = aFormats_(0) Else aFormats = aFormats_ End If End If Set oFS = New Scripting.FileSystemObject If Overwrite Then If oFS.FileExists(sFilename) Then oFS.DeleteFile (sFilename) End If DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, sTable, sFilename, True Set oApp = New Excel.Application oApp.Visible = False DisplayAlerts = oApp.DisplayAlerts oApp.DisplayAlerts = False Set oWkb = oApp.Workbooks.Open(sFilename) Set oSh = oWkb.Sheets(oWkb.Sheets.Count) For Each sFormat In aFormats aCurFmt = Split(sFormat, ";") If UBound(aCurFmt) = 1 Then 'aCurFmt(0) = Column letter 'aCurFmt(1) = Format If InStr(aCurFmt(0), ":") > 0 Then oSh.Range(aCurFmt(0)).EntireColumn.NumberFormat = aCurFmt(1) Else oSh.Range(aCurFmt(0) & ":" & aCurFmt(0)).EntireColumn.NumberFormat = aCurFmt(1) End If End If Next oSh.Cells.Font.Name = "Arial" oSh.Cells.Font.Size = 8 oSh.Range("A1").EntireRow.Font.Bold = True oSh.Range("A1").EntireRow.WrapText = True ' With oSh.Range("A1").EntireRow ' .Replace ".", "#" ' End With oSh.UsedRange.Columns.AutoFit oSh.Name = TabName oWkb.Names(Replace(sTable, " ", "_")).Delete oWkb.Save oWkb.Close True 'Reset this setting; I think it's sticky. oApp.DisplayAlerts = DisplayAlerts oApp.Quit Set oSh = Nothing Set oWkb = Nothing Set oApp = Nothing Set oFS = Nothing Exit Sub Err_Handler: If Not TypeName(oApp) Like "Nothing" Then oApp.Visible = True End If MsgBox Err.Description, vbCritical, "Error " & Err.Number End Sub
Run Numbered Queries in an Access Database
If you have a series of numbered queries (i.e. “01 Query to make a table”, “02 Query to update table 1”, “03 Query to make another table”, etc…), run them in order. You can change the pattern to search for, so that you can match a different numbering system.
Sub Run_All_Numbered_QueryDefs(Optional ByVal Pattern As String = "##*") DoCmd.SetWarnings False With CurrentDb.OpenRecordset("SELECT Name FROM MsysObjects WHERE Type=5 AND Name Like '" & Pattern & "' ORDER BY Name") Do While Not .EOF DoCmd.OpenQuery .Fields("Name").Value .MoveNext Loop .Close End With DoCmd.SetWarnings True End Sub
Parse a Connection String
Sample connection string:
DSN=DatabaseDSN;APP=Microsoft® Access;WSID=COMPUTER_ID;DATABASE=queries;Address=SQL_SERVER_DB,1433;Trusted_Connection=Yes
Requires a reference to VBScript Regular Expressions Library 5.5
Function ParseConn(strConn, variable, Optional ByVal replace = "") Dim rx As RegExp Dim mc As MatchCollection Set rx = New RegExp rx.Pattern = variable & "=.*?(;|$)" If Not replace = "" Then ParseConn = rx.replace(strConn, variable & "=" & replace & ";") Exit Function End If Set mc = rx.Execute(strConn) If mc.Count > 0 Then rx.Pattern = "=.*[^;]" Set mc = rx.Execute(mc(0)) ParseConn = Right(mc(0), Len(mc(0)) - 1) End If End Function
Truncate a Double to N Digits
Function Truncate(Num As Double, Digits As Integer) As Double Dim i, Pwr If Digits > 10 Then Exit Function Pwr = 10 ^ Digits Num = Num * Pwr i = InStr(Num, ".") If i > 0 Then Num = Left(Num, i - 1) End If Truncate = (Num / Pwr) End Function
Collection To Array
Function CollectionToArray(c As Collection) ReDim a(c.Count - 1) k = 0 For Each i In c a(k) = i: k = k + 1 Next CollectionToArray = a End Function
DConcat – Domain String Concatenation
Use this function to concatenate different items you are trying to roll up in a group. For example:
Table 1 |
|
Field 1 |
Field 2 |
A |
1 |
A |
2 |
A |
3 |
B |
1 |
B |
2 |
SELECT t.Field1, DConcat('[Field2]','[Table1]','[Field1]=''' & [Field1] & '''') AS Expr1 FROM Table1 AS t GROUP BY t.Field1;
Results |
|
Field1 |
Expr1 |
A |
1,2,3 |
B |
1,2 |
This is not the most efficient way to do string concatenation over a table, but so far it is the cleanest I’ve found.
Function DConcat(Expr, Domain, Optional Criteria = "", Optional Delim = ",") Dim oRS As ADODB.Recordset sSQL = "SELECT " & Expr & " FROM " & Domain & " " & IIf(Criteria = "", "", "WHERE " & Criteria) Set oRS = New ADODB.Recordset oRS.Open sSQL, CurrentProject.Connection, adOpenKeyset If Not oRS.EOF Then DConcat = oRS.GetString(adClipString, -1, vbNullString, Delim) If Not DConcat = "" Then DConcat = Left(DConcat, Len(DConcat) - Len(Delim)) End If oRS.Close Set oRS = Nothing End Function
Update UID and PWD in all pass-through queries in a database
Requires the ParseConn() function, above.
Sub Update_Connection() sUser = InputBox("Please enter your user name") If sUser = "" Then Exit Sub sPass = InputBox("Please enter your password") If sPass = "" Then Exit Sub With CurrentDb.OpenRecordset("SELECT * FROM MSysObjects WHERE Flags IN (144,112)") While Not .EOF tbl = .Fields("Name").Value sConn = CurrentDb.QueryDefs(tbl).Connect sConn = ParseConn(sConn, "UID", sUser) sConn = ParseConn(sConn, "PWD", sPass) Debug.Print sConn CurrentDb.QueryDefs(tbl).Connect = sConn .MoveNext Wend End With MsgBox "Connections updated. Please close and re-open the database." End Sub
A very simple Stack implementation
Paste this code into a Class module
Dim Stack__ As Collection Private Sub Class_Initialize() Set Stack__ = New Collection End Sub Sub Push(o As Variant) Stack__.Add o End Sub Function Pop() As Variant If Stack__.Count > 0 Then If IsObject(Stack__(Stack__.Count)) Then Set Pop = Stack__(Stack__.Count) Else Pop = Stack__(Stack__.Count) End If Stack__.Remove Stack__.Count End If End Function Function Count() As Long Count = Stack__.Count End Function
Check if a table has an index on a particular field
Function HasIndexOn(sTable, sField) HasIndexOn = False For i = 0 To CurrentDb.TableDefs(sTable).Indexes.Count - 1 If CurrentDb.TableDefs(sTable).Indexes(i).Fields.Count = 1 Then If CurrentDb.TableDefs(sTable).Indexes(i).Fields(0).Name = sField Then HasIndexOn = True End If End If Next End Function
QuerySheet(): Run SQL queries directly on Excel worksheets
Run SQL queries on Excel worksheets directly. You can even run updates on them.
In your SQL use %table(0)%, %table(1)%, etc… to designate different sheets as tables.
'Requires a reference to Microsoft ActiveX DataObjects 2.8 Library Function QuerySheet(sSQL, ParamArray Worksheets()) As ADODB.Recordset Dim oSh Dim sConn, n On Error GoTo QuerySheet_Err Set QuerySheet = New ADODB.Recordset sConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Worksheets(0).Parent.FullName & ";Extended Properties=""Excel 8.0;HDR=Yes"";" n = 0 For Each oSh In Worksheets sSQL = Replace(sSQL, "%table(" & n & ")%", "[" & oSh.Name & "$]") n = n + 1 Next QuerySheet.Open sSQL, sConn Exit Function QuerySheet_Err: MsgBox "Error in QuerySheet(): " & Err.Description End End Function
ElementIn function; similar to the SQL IN operator
Function ElementIn(Element, ParamArray ElementList()) As Boolean Dim i ElementIn = False For Each i In ElementList If i = Element Then ElementIn = True Exit Function End If Next End Function
String Tokenizer Class
Add to StringTokenizer class:
Option Compare Database Option Explicit Dim item__ As String Dim tokpos__ As Integer Dim delim__ As String Sub SetData(strItem As String, chrDelim As String) item__ = strItem tokpos__ = 1 delim__ = chrDelim End Sub Function GetToken() Dim intNextDelim As Integer, strToken As String intNextDelim = InStr(item__, delim__) If intNextDelim > 0 Then strToken = Left(item__, (intNextDelim - 1)) item__ = Right(item__, Len(item__) - intNextDelim) Else strToken = item__ item__ = "" End If tokpos__ = intNextDelim + 1 GetToken = strToken End Function Function GetRemainingString() GetRemainingString = item__ End Function
GroupIncrement Function
You can use this function in your queries in a method similar to the ROW_NUMBER() OVER (PARTITION BY…) statement in SQL Server. See usage below.
Function GroupIncrement(ByVal sGroup) Static Num, LastGrp If (StrComp(LastGrp, Nz(sGroup, "")) <> 0) Then Num = 0 End If Num = Num + 1 GroupIncrement = Num LastGrp = sGroup End Function
Sample usage:
Query 1: ALTER TABLE [SampleTable] ADD COLUMN [Row] int Query 2: UPDATE (SELECT * FROM [SampleTable] ORDER BY [PartitionGroup], [Col1], [Col2], ..., [ColN]) SET [Row]=GroupIncrement([PartitionGroup])
Automatically Download a File using HTTP
Sub GetWebFile(sURL As String, sOutFile As String) Dim oHTTP Dim oStream Dim oFS Const adTypeBinary_ = 1 Const adTypeText_ = 2 Const adSaveCreateOverWrite_ = 2 'Get the file from the URL Set oHTTP = CreateObject("Microsoft.XMLHTTP") oHTTP.Open "GET", sURL, False oHTTP.send 'Write the data into a stream Set oStream = CreateObject("ADODB.Stream") oStream.Type = adTypeBinary_ oStream.Open oStream.Write oHTTP.responseBody Set oFS = CreateObject("Scripting.FilesystemObject") 'Delete the old file If oFS.FileExists(sOutFile) Then oFS.DeleteFile sOutFile 'Save the file. oStream.SaveToFile sOutFile oStream.Close Set oFS = Nothing Set oStream = Nothing Set oHTTP = Nothing End Sub
Programatically Removing Broken References in MSAccess/VBA
I could not get this to work using For Each r In Application.References, but finally found a working solution in this thread.
i = 1 With Application.References Do While i <= .Count If .Item(i).IsBroken Then .Remove .Item(i) End If i = i + 1 Loop End With
Class to Scan Excel Files and Return Range Types And Addresses
Save these 2 files as text files and use the “Import File…” menu item in the VBA editor.
ExcelRangeTypeCollection.cls:
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "ExcelRangeTypeCollection" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Compare Database Private c As Collection Private FileName_ As String Private Sub Class_Initialize() Set c = New Collection End Sub Private Sub Class_Terminate() Set c = Nothing End Sub Public Sub ReadWorkbook(FileName) GetWorksheets FileName End Sub Public Property Get NewEnum() As IUnknown Attribute NewEnum.VB_UserMemId = -4 Attribute NewEnum.VB_MemberFlags = "40" Set NewEnum = c.[_NewEnum] End Property Sub Add(Item As ExcelRangeType, Optional Key, Optional Before, Optional After) c.Add Item, Key, Before, After End Sub Function Count() As Long Count = c.Count End Function Public Function Item(Index) As ExcelRangeType Attribute Item.VB_UserMemId = 0 Item = c.Item(Index) End Function Sub Remove(Index) c.Remove Index End Sub Private Sub GetWorksheets(FileName) Dim XlApp As Excel.Application Set XlApp = New Excel.Application Dim Wkb As Excel.Workbook Set Wkb = XlApp.Workbooks.Open(FileName) Dim Range As Excel.Range Dim Wks As Excel.Worksheet Dim Result As ExcelRangeTypeCollection Dim RangeType As ExcelRangeType Set Result = Me Dim Name As Excel.Name For Each Wks In Wkb.Sheets Set RangeType = New ExcelRangeType RangeType.Name = Wks.Name RangeType.RangeType = Worksheet RangeType.RangeAddress = Wks.UsedRange.Address(True, True, xlA1, True) Result.Add RangeType For Each Name In Wks.Names RangeType.Name = Name.Name RangeType.RangeType = WorksheetNamedRange RangeType.RangeAddress = Name.RefersTo Result.Add RangeType Next Next For Each Name In Wkb.Names RangeType.Name = Name.Name RangeType.RangeType = WorkbookNamedRange RangeType.RangeAddress = Name.RefersTo Result.Add RangeType Next XlApp.Quit End Sub
ExcelRangeType.cls:
VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "ExcelRangeType" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Compare Database Enum ExcelTypeEnum Worksheet = 0 WorkbookNamedRange = 1 WorksheetNamedRange = 2 End Enum Public Name As String Public RangeType As ExcelTypeEnum Public RangeAddress As String