Access VBA Import Text File Stops Halfway

I'm using Access 2013. I'm trying to import a .txt file into Access. The text file is 700MB (19MM records). My code filters the data and assigns a group value ("Inode") to keep associated records together - so I'm only bringing in roughly 600K records.

Here is a snippet of the source text file (you can see each Inode data group is separated by a dashed line):

enter image description here

I would like the final result to look like this:

enter image description here

For some reason, the program STOPS halfway through, at the SAME RECORD (roughly 8MM record mark). I can't locate what the issue is. I don't think it's a size issue as I have plenty of space. I've tried implementing error handling, but to no avail. The code simply bypasses it and the program ends (msgbox "done" appears). Opening the text file and reviewing the record where it stops does not help. There is nothing wrong/different about that record. It simply stops and I am baffled.

Here is the code:

Private Sub ImportTextFile()
On Error GoTo Err_LogError
Dim strFile As String, strLine As String
Dim lngFreeFile
Dim sInode_Num As String
Set db = CurrentDb()
DAO.DBEngine.SetOption dbMaxLocksPerFile, 1000000  <--- not sure if this helps
Set rs = db.OpenRecordset("tblImport")
strFile = "C:\Data\store_data.txt"

    lngFreeFile = FreeFile
    Open strFile For Input As #lngFreeFile
    Do Until EOF(lngFreeFile)
        Line Input #lngFreeFile, strLine

    If Left(LCase(Trim(strLine)), 9) = "inode_num" Then
        sInode_Num = Trim(strLine)
    End If    

    If InStr(LCase(strLine), "kmditemlastuseddate") > 0 Or _
       InStr(LCase(strLine), "kmditemusecount") > 0 Or _
       InStr(LCase(strLine), "kmditemuseddates") > 0 Or _
       InStr(LCase(strLine), "kmditemdateadded") > 0 Then

        rs.AddNew
        rs![Inode_Num] = sInode_Num
        rs![FieldValue] = Trim(strLine)
        rs.Update

        End If
    Loop

Exit_LogError:
    MsgBox "done."
    Close #lngFreeFile
    Set rst = Nothing
    Exit Sub

Err_LogError:
    strMsg = "Error: " & Err.Number & vbCrLf & Err.Description
    MsgBox strMsg, vbCritical, "LogError()"
    Resume Exit_LogError

End Sub

NOTE: I used SSMS import wizard and was able to ingest the text file in its' entirety (19MM records) in just a few minutes. But the key to this is getting that Inode grouping so I can keep the associated records together. If there is a way to do that through the wizard i'd like to know.

Any assistance would be greatly appreciated. Thank you!

1 answer

  • answered 2018-11-08 22:09 Craig

    I think I found the solution..working from Erik's observation regarding "open strFile for Input" limitations. I found some code that uses CreateObject("Scripting.FileSystemObject"). Then with "obj.Readline" I can read each line separately, as opposed to reading the entire 19MM records into one recordset.

    The new code is here:

    Public Function ReadTextFile()
        On Error GoTo Err_LogError
    
        Dim objFSO As Object
        Dim objTextStream As Object
        Dim strTextLine As String
        Dim strInputFileName As String
        Set db = CurrentDb()
        Set rs = db.OpenRecordset("tblImport")
        strInputFileName = "C:\Data\store_data.txt"
    
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objTextStream = objFSO.OpenTextFile(strInputFileName)
    
        Do While Not (objTextStream.AtEndOfStream)
            strTextLine = objTextStream.ReadLine
    
                If Left(LCase(Trim(strTextLine)), 9) = "inode_num" Then
                    sInode_Num = Trim(strTextLine)
                End If
                '
                If InStr(LCase(strTextLine), "kmditemlastuseddate") > 0 Or _
                   InStr(LCase(strTextLine), "kmditemusecount") > 0 Or _
                   InStr(LCase(strTextLine), "kmditemuseddates") > 0 Or _
                   InStr(LCase(strTextLine), "kmditemdateadded") > 0 Then
                '
                rs.AddNew
                rs![Inode_Num] = sInode_Num
                rs![FieldValue] = Trim(strTextLine)
                rs.Update
    
                End If
    
        Loop
    
        Exit_LogError:
            objTextStream.Close
            Set objFSO = Nothing
            Set objTextStream = Nothing
            MsgBox "done."
            Exit Function
    
        Err_LogError:
            strMsg = "Error: " & Err.Number & vbCrLf & Err.Description
            MsgBox strMsg, vbCritical, "LogError()"
            Resume Exit_LogError
    
        End Function