Useful VBA/VB Subroutines and Functions

If you are a Microsoft Access programmer, and would like syntax highlighting and formatting for your SQL queries, please try out my new Access Add-In: Access SQL Editor!

There is a 14-day trial here, and you may purchase it here. For support, please contact me at signature.gif

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

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.

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
    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
                    Exit Function
                End If
        End With
        '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 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)
    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()
    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
        .Fields(sField) = sValue
    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.
        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)
            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)
                oSh.Range(aCurFmt(0) & ":" & aCurFmt(0)).EntireColumn.NumberFormat = aCurFmt(1)
            End If
        End If
    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.Name = TabName
    oWkb.Names(Replace(sTable, " ", "_")).Delete
    oWkb.Close True
    'Reset this setting; I think it's sticky.
    oApp.DisplayAlerts = DisplayAlerts
    Set oSh = Nothing
    Set oWkb = Nothing
    Set oApp = Nothing
    Set oFS = Nothing
    Exit Sub
    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
    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
    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












SELECT t.Field1, DConcat('[Field2]','[Table1]','[Field1]=''' & [Field1] & '''') AS Expr1
FROM Table1 AS t
GROUP BY t.Field1;









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
    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
    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)
            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
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
    QuerySheet.Open sSQL, sConn
    Exit Function
    MsgBox "Error in QuerySheet(): " & Err.Description
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
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)
        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
    'Write the data into a stream
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Type = adTypeBinary_
    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
    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
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.


  MultiUse = -1  'True
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
    For Each Name In Wkb.Names
        RangeType.Name = Name.Name
        RangeType.RangeType = WorkbookNamedRange
        RangeType.RangeAddress = Name.RefersTo
        Result.Add RangeType
End Sub



  MultiUse = -1  'True
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

Link a Table Using DAO

Sub Test_LinkTable()
 LinkTable CurrentDb(), "ODBC;DRIVER=SQL Server;UID=MyUserID;PWD=UsersPassword;DATABASE=TheDatabase;SERVER=SqlServerInstance", "tblOrder", "dbo_Orders"
End Sub

Sub LinkTable(db As DAO.Database, connString As String, srcTblName As String, dstTblName As String)
 Dim tbl As DAO.TableDef
 On Error Resume Next
 'Delete the linked table if it already exists
 db.TableDefs.Delete dstTblName
 On Error GoTo 0
 Set tbl = db.CreateTableDef()
 tbl.Connect = connString
 tbl.SourceTableName = srcTblName
 tbl.Name = dstTblName
 db.TableDefs.Append tbl
End Sub


Encode/Decode Base 64


VB6: Free, Easy and Quick Base64 Encoding and Decoding in Visual Basic

Above site is no longer available, so retrieved via wayback machine:

Private Function EncodeBase64(ByRef arrData() As Byte) As String
    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement
    ' help from MSXML
    Set objXML = New MSXML2.DOMDocument
    ' byte array to base64
    Set objNode = objXML.createElement("b64")
    objNode.dataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.Text
    ' thanks, bye
    Set objNode = Nothing
    Set objXML = Nothing
End Function
Private Function DecodeBase64(ByVal strData As String) As Byte()
    Dim objXML As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMElement
    ' help from MSXML
    Set objXML = New MSXML2.DOMDocument
    Set objNode = objXML.createElement("b64")
    objNode.dataType = "bin.base64"
    objNode.Text = strData
    DecodeBase64 = objNode.nodeTypedValue
    ' thanks, bye
    Set objNode = Nothing
    Set objXML = Nothing
End Function


Dynamically Add Code to a VBA Project

Type Libraries in VBA


IDL and type libraries in VBA

Updating a Linked Excel Table in Access 2007


IMEX must be set to 0. Use ADOX.Catalog to change Jet OLEDB:Link Provider String.

Function ChangeImex(linkedTblName)
 Dim cat 'As ADOX.Catalog
 Dim rx 'As VBScript_RegExp_55.RegExp
 Dim conn
 Set rx = CreateObject("VBScript.Regexp")
 Set cat = CreateObject("ADOX.Catalog")
 rx.Pattern = "(IMEX=)(.+?)(;{0,1})"
 cat.ActiveConnection = CurrentProject.Connection
 With cat.Tables(linkedTblName)
 conn = .Properties("Jet OLEDB:Link Provider String").Value
 conn = rx.Replace(conn, "$10$3")
 .Properties("Jet OLEDB:Link Provider String").Value = conn
 End With
End Function