Create an Access Database File and Import a Text File to a Table Within Using VBA

Access' 2GB file size limit has been a thorn in the side of developers for years, but it is possible to circumvent. One option is to create link tables to external text files instead of importing them, but this snippet of code explains how to create a disposable Access database to hold the data from just one table.

This doesn't increase the speed at which Access handles data and it takes up more space on the hard drive, but it does add some functionality like the ability to update records. The code below assumes that the Access file is disposable and designed to hold just one table, so it deletes the file if it already exists.

So much of this code is shamelessly recycled from the VBA snippet that imports a text file into an Access table which is included in Jimbo's VBA Automation Toolbox. It is doctored just enough to get the data into a disposable Access file.

The text files can be extracts from another team, clipboard copies from SE16 or a query from a SQL server saved directly to text. The last parameter of the function is the delimiter that defaults to Tab.

Sub TestA()
    Dim y
    y = ImportTextToExternalAccessDB("c:\stuff\PlantMagic\MARC.txt", "c:\stuff\PlantMagic\TestMARC.accdb", "tblMARC")
End Sub


Function ImportTextToExternalAccessDB(strFileName As String, strAccessFileName As String, strTableName As String, Optional ByVal strDelim As String = vbTab)

    'This code assumes each Access file will hold just one table.
    If Len(Dir(strAccessFileName)) > 0 Then
        Kill strAccessFileName
    End If
    Dim accessApp As Access.Application
    Set accessApp = New Access.Application
    accessApp.DBEngine.CreateDatabase strAccessFileName, DB_LANG_GENERAL
    accessApp.Quit
    Set accessApp = Nothing
    
    Dim db As Database
    Set db = OpenDatabase(strAccessFileName)
   
    Dim rs As DAO.Recordset
    Dim nCurrent As Long, nFieldCount As Long, nRecordCount As Long
    Dim RetVal As Variant, nCurRec As Long, dnow As Date, nCurSec As Long
    Dim nTotalSeconds As Long, nSecondsLeft As Long
    Dim nTotalbytes As Long, nFileLen As Long
    Dim strTest As Variant
    Dim strTemp As String
    Dim strHeadersIn() As String
    Dim strHeaders(999) As String
    Const nReadAhead As Long = 300000
    Dim nSizes(999) As Long, strRecords(nReadAhead) As String, nRecords As Long, nLoaded As Long
    Dim strFields() As String
    
    Dim nHeaders As Long
    Dim isSAP As Boolean
    
    nFileLen = FileLen(strFileName)
    RetVal = SysCmd(acSysCmdSetStatus, "Preparing to import " & strTableName & " from " & strFileName & "...")
    RetVal = DoEvents()
    
    Open strFileName For Input As #1
    Line Input #1, strTest
    If Left(strTest, 6) = "Table:" Then 'This is an SAP extract!
        isSAP = True
        Line Input #1, strTest
        Line Input #1, strTest
        Line Input #1, strTest  'Fourth line has the headers!
    Else
        isSAP = False
    End If
    
    If InStr(1, strTest, "|", vbTextCompare) Then
        strDelim = "|"
    End If
    
    nTotalbytes = nTotalbytes + Len(strTest) + 2 ' +2 for vbCrLf--This line prevents div by zero later...
    strTest = Trim(strTest)
    If Right(strTest, 1) = strDelim Then
        strTest = Left(strTest, Len(strTest) - 1)
    End If
    strHeadersIn = Split(Trim(strTest), strDelim)
    nHeaders = 0
    
    
    For Each strTest In strHeadersIn
        nHeaders = nHeaders + 1
        strTest = Replace(Replace(strTest, " ", ""), ".", "")
        strTest = Replace(Replace(strTest, " ", ""), ".", "")
        If Len(Trim(strTest)) = 0 Then
            strHeaders(nHeaders) = "HEADER" & Right("000" & nHeaders, 3)
        Else
            strHeaders(nHeaders) = Trim(strTest)
        End If
        For nCurrent = 1 To nHeaders - 1
            If strHeaders(nHeaders) = strHeaders(nCurrent) Then
                strHeaders(nHeaders) = strHeaders(nHeaders) & nHeaders
            End If
        Next
    Next
    strHeaders(0) = nHeaders
    RetVal = SysCmd(acSysCmdClearStatus)
    RetVal = SysCmd(acSysCmdInitMeter, "Preparing to import " & strTableName & " from " & strFileName & "...", nReadAhead)
    RetVal = DoEvents()
    
    Do While Not EOF(1) And nRecords < nReadAhead 'Read through the file and get the maximum sizes for fields in advance.
        Line Input #1, strTest
        strTest = Trim(strTest)
        If Right(strTest, 1) = strDelim Then
            strTest = Left(strTest, Len(strTest) - 1)
        End If
        If isSAP And Left(strTest, 20) = "--------------------" Then
            strTest = ""  'Skip this line!
        End If
        If Len(strTest) > 0 Then
            nRecords = nRecords + 1
            strRecords(nRecords) = strTest
            strFields = Split(strTest, strDelim)
            nCurrent = 0
            For Each strTest In strFields
                nCurrent = nCurrent + 1
                If Len(strTest) > nSizes(nCurrent) Then
                    nSizes(nCurrent) = Len(strTest)
                End If
            Next
            If Second(Now) <> nCurSec Then
                nCurSec = Second(Now)
                RetVal = SysCmd(acSysCmdUpdateMeter, nRecords)
                RetVal = DoEvents()
            End If
        End If
    Loop
    
    
    If CreateExternalAccessTable(strAccessFileName, strTableName, strHeaders, nSizes) Then
        If isSAP Then
            For nCurrent = 1 To nHeaders
                If Left(strHeaders(nCurrent), 8) = "HEADER00" Then
                    strHeaders(nCurrent) = ""  'Don't bother importing this field.
                End If
            Next
        End If
        Set rs = db.OpenRecordset(strTableName)
        nLoaded = 0
        nTotalSeconds = 0
        Do While Not EOF(1) Or nLoaded < nRecords
            nCurRec = nCurRec + 1
            If Second(Now()) <> nCurSec Then
                nCurSec = Second(Now())
                nTotalSeconds = nTotalSeconds + 1
                'RetVal = DoEvents()
                If nTotalSeconds > 3 Then
                    'nSecondsLeft = Int(((nTotalSeconds / nCurRec) * rs.RecordCount) * ((rs.RecordCount - nCurRec) / rs.RecordCount))
                    nSecondsLeft = Int(((nTotalSeconds / nTotalbytes) * nFileLen) * ((nFileLen - nTotalbytes) / nFileLen))
                    RetVal = SysCmd(acSysCmdRemoveMeter)
                    RetVal = SysCmd(acSysCmdInitMeter, "Importing " & strTableName & " from " & strFileName & "... " & nSecondsLeft & " seconds remaining.", nFileLen)
                    RetVal = SysCmd(acSysCmdUpdateMeter, nTotalbytes)
                    RetVal = DoEvents()
                End If
            End If
            If nLoaded < nRecords Then
                nLoaded = nLoaded + 1
                strTest = strRecords(nLoaded)
            Else
                Line Input #1, strTest
            End If
            nTotalbytes = nTotalbytes + Len(strTest) + 2 'vbCrLf
            strTest = Trim(strTest)
            If Right(strTest, 1) = strDelim Then
                strTest = Left(strTest, Len(strTest) - 1)
            End If
            If isSAP And Left(strTest, 20) = "--------------------" Then
                strTest = ""  'Skip this line!
            End If
            If Len(strTest) > 0 Then
                strFields = Split(strTest, strDelim)
                nCurrent = 0
                rs.AddNew
                For Each strTest In strFields
                    nCurrent = nCurrent + 1
                    If Len(Trim(strHeaders(nCurrent))) > 0 Then
                        'rs.FIELDS(strHeaders(nCurrent)).Value = Trim(strFields(nCurrent - 1))
                        rs.FIELDS(strHeaders(nCurrent)).Value = Left(Trim(strFields(nCurrent - 1)), rs.FIELDS(strHeaders(nCurrent)).Size)
                    End If
                Next
                rs.Update
            End If
        Loop
        rs.Close
    End If
    Close #1
    RetVal = SysCmd(acSysCmdRemoveMeter)

   
End Function

Function CreateExternalAccessTable(strAccessFileName As String, strTableName As String, strFields() As String, nSizes() As Long) As Boolean
    Dim nCounter As Long
    Dim dbs As DAO.Database
    'Now create the database.  Rename the old database if necessary.
    'Set dbs = CurrentDb
    Set dbs = OpenDatabase(strAccessFileName)
    Dim tdf As DAO.TableDef
    Dim fld1 As DAO.Field
    Dim fld2 As DAO.Field
    Dim fName As String
    Dim fType As Integer
    Dim fSize As Integer
    
    On Error GoTo ErrorHandler
    'Check for existence of TargetTable
    nCounter = 0
    Do While nCounter < dbs.TableDefs.Count
        If dbs.TableDefs(nCounter).Name = strTableName Then
            'Delete TargetTable--must start from scratch
            dbs.TableDefs.Delete (strTableName)
        End If
        nCounter = nCounter + 1
    Loop
    
    Set tdf = dbs.CreateTableDef(strTableName)
    For nCounter = 1 To Val(strFields(0))
        fName = strFields(nCounter)
        fType = dbText
        fSize = nSizes(nCounter) 'fSize = 255
        Set fld1 = tdf.CreateField(fName, fType, fSize)
        fld1.AllowZeroLength = True
        fld1.Required = False
        tdf.FIELDS.Append fld1
    Next
    'Create the table in the database
    dbs.TableDefs.Append tdf
    dbs.TableDefs.Refresh
    CreateExternalAccessTable = True
    Exit Function
ErrorHandler:
    MsgBox "Error number " & Err.Number & ": " & Err.Description
    CreateExternalAccessTable = False
    Exit Function
End Function

Note: This snippet of code relies on several referenced DLLs. Be sure to add these in the Module to ensure that this code functions.