---

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.

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:

 

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
    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

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
 db.TableDefs.Refresh
 On Error GoTo 0
 
 Set tbl = db.CreateTableDef()
 tbl.Connect = connString
 tbl.SourceTableName = srcTblName
 tbl.Name = dstTblName
 db.TableDefs.Append tbl
End Sub

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

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