Sub LargeDatabaseImport()
'In the event of an error, make sure the application is reset to
'normal.
On Error GoTo ErrorCheck
'Dimension Variables
Dim ResultStr As String
Dim FileName As String
Dim FileNum As Integer
Dim Counter As Double
Dim CommaCount As Integer
Dim WorkResult As String
'Ask for the name of the file.
FileName = InputBox("Please type the name of your text file, for example, test.txt")
'Turn off ScreenUpdating and Events so that users can't see what is
'happening and can't affect the code while it is running.
Application.ScreenUpdating = False
Application.EnableEvents = False
'Check for no entry.
If FileName = "" Then End
'Get next available file handle number.
FileNum = FreeFile()
'Open text file for input.
Open FileName For Input As #FileNum
'Turn ScreenUpdating off.
Application.ScreenUpdating = False
'Set the counter to 1.
Counter = 1
'Place the data in the first row of the column.
Range("A1").Activate
'Loop until the end of file is reached.
Do While Seek(FileNum) <= LOF(FileNum)
'Show row number being imported on status bar.
Application.StatusBar = "Importing Row " & _
Counter & " of text file " & FileName
'Store one line of text from file to variable.
Line Input #FileNum, ResultStr
'Initialize the CommaCount variable to zero.
CommaCount = 0
'Store the entire string into a second, temporary string.
WorkResult = ResultStr
'Parse through the first line of data and separate out records
'257 to 510.
While CommaCount < 255
WorkResult = Right(WorkResult, Len(WorkResult) - InStr(1, WorkResult, ","))
CommaCount = CommaCount + 1
Wend
'Parse out any leading spaces.
If Left(WorkResult, 1) = " " Then WorkResult = Right(WorkResult, Len(WorkResult) - 1)
'Ensure that any records that contain an "=" sign are
'brought in as text, and set the value of the current
'cell to the first 256 records.
If Left(WorkResult, 1) = "=" Then
ActiveCell.Value = "'" & Left(ResultStr, Len(ResultStr) - Len(WorkResult))
Else
ActiveCell.Value = Left(ResultStr, Len(ResultStr) - Len(WorkResult))
End If
'Ensure that any records that contain an "=" sign are
'brought in as text,and set the value of the next cell
'to the last 256 records.
If Left(WorkResult, 1) = "=" Then
ActiveCell.Offset(0, 1).Value = "'" & WorkResult
Else
ActiveCell.Offset(0, 1).Value = WorkResult
End If
'Move down one cell.
ActiveCell.Offset(1, 0).Activate
'Increment the Counter by 1.
Counter = Counter + 1
'Start again at top of 'Do While' statement.
Loop
'Close the open text file.
Close
'Take records 257-510 and move them to sheet two.
Columns("B:B").Select
Selection.Cut
Sheets("Sheet2").Select
Columns("A:A").Select
ActiveSheet.Paste
'Run the text-to-columns wizard on both sheets.
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
Sheets("Sheet1").Select
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
'Reset the application to its normal operating environment.
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
ErrorCheck:
'Reset the application to its normal operating environment.
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "An error occured in the code."
End Sub
