Import data from a large text file to multiple worksheets (ADO)
2004-12-17 ADO 0 690
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
The macro examples 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 the Microsoft ActiveX Data Objects x.x Object Library.See information about using a Schema.ini file to set information about e.g. column data types and separator characters.