These pages are no longer updated and are only available for archive purposes.

Click here to visit the pages with updated information.

Import data from a large text file to multiple worksheets (ADO)

The procedure below can be used to create a dummy text file containing 1 000 000 semi-colon separated records:

Sub CreateTextFileDB()
Dim strTextFile As String, f As Integer
Dim strItem1 As String, strItem2 As String
Dim i As Long, j As Long
    strTextFile = "C:\Temp\" & Format(Date, "yyyymmdd") & ".txt"
    On Error Resume Next
    Kill strTextFile
    On Error GoTo 0
    f = FreeFile
    Open strTextFile For Append As #f
    Print #f, "ITEM1;ITEM2;VALUEi;VALUEj;PRODUCT"
    For i = 1 To 100
        strItem1 = "ITEM" & Format(i, "000")
        Application.StatusBar = "Writing data for " & strItem1 & "..."
        For j = 1 To 10000
            strItem2 = "item" & Format(j, "00000")
            Print #f, strItem1 & ";" & strItem2 & ";" & i & ";" & j & ";" & i * j
        Next j
        DoEvents
    Next i
    Close #f
    Application.StatusBar = False
End Sub

The procedure below can be used to read input from a text file (such as the dummy file created by the procedure above), and put the records for each unique item in a field/column into a separate worksheet:

Sub CreateNewWorkbookFromTextFile(strFolder As String, strTextFile As String)
' use like this: CreateNewWorkbookFromTextFile "C:\Temp", "TextFileName.txt"
Dim cn As ADODB.Connection, rs As ADODB.Recordset, rsItems As ADODB.Recordset
Dim wb As Workbook, ws As Worksheet, i As Long, f As Long, strSQL As String
    If Len(strFolder) = 0 Then Exit Sub
    If Len(strTextFile) = 0 Then Exit Sub
    
    Set cn = New ADODB.Connection
    On Error Resume Next
    cn.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
        "Dbq=" & strFolder & ";" & _
        "Extensions=asc,csv,tab,txt;"
    On Error GoTo 0
    If cn.State <> adStateOpen Then Exit Sub
    
    ' get all unique items from one field
    Set rsItems = New ADODB.Recordset
    strSQL = "select distinct ITEM1 from " & strTextFile
    On Error Resume Next
    rsItems.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
    On Error GoTo 0
    If rsItems.State <> adStateOpen Then ' did not find anything
        Set rsItems = Nothing
        cn.Close
        Set cn = Nothing
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    ' create a new workbook
    Set wb = Workbooks.Add
    
    i = 0
    Do While Not rsItems.EOF ' for each unique field item
        Application.StatusBar = "Reading data for " & rsItems(0).Value & "..."
        i = i + 1
        strSQL = "select * from " & strTextFile & " where ITEM1 = '" & rsItems(0).Value & "'"
        Set rs = New ADODB.Recordset
        On Error Resume Next
        rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly, adCmdText
        On Error GoTo 0
        If rs.State = adStateOpen Then
            Application.StatusBar = "Writing data for " & rsItems(0).Value & "..."
            With wb
                If i > .Worksheets.Count Then ' add a new worksheet
                    .Worksheets.Add After:=.Worksheets(.Worksheets.Count)
                End If
                With .Worksheets(i) ' populate the item worksheet
                    ' write field headings
                    For f = 0 To rs.Fields.Count - 1
                        .Range("A1").Offset(0, f).Formula = rs.Fields(f).Name
                    Next f
                    .Rows(1).Font.Bold = True
                    ' write data records
                    .Range("A2").CopyFromRecordset rs, .Rows.Count - 1, Columns.Count
                    .Columns("A:IV").AutoFit
                End With
            End With
            rs.Close
        End If
        Set rs = Nothing
        rsItems.MoveNext
        Application.StatusBar = False
        DoEvents
    Loop
    rsItems.Close
    Set rsItems = Nothing
    cn.Close
    Set cn = Nothing
    wb.Worksheets(1).Activate
    Set wb = Nothing
    Application.ScreenUpdating = True
End Sub

If you use the procedure above to create a dummy text file with 1 000 000 records, you can create a workbook with 100 worksheets containing 10 000 records each like this:

Sub TestCreateNewWorkbookFromTextFile()
    CreateNewWorkbookFromTextFile "C:\Temp", Format(Date, "yyyymmdd") & ".txt"
End Sub

This macro example assumes that your VBA project has added a reference to the ADO object library.
You can do this from within the VBE by selecting the menu Tools, References and selecting Microsoft ActiveX Data Objects x.x Object Library.

Document last updated 2004-12-17 20:28:48