Import a Delimited Text File

[ScottSmith]

I want to import a delimited text file with a macro. Using the record function gives me all the code to do it, but, that doesn't give me the flexibilty to open different file names. The file name is hard coded in.

I've tried the: Application.GetOpenFilename and set that equal to a variable but kept getting an Run-Time Error 1004 (application/object defined error) When I subsituted the File path name for the variable

Here are the 2 code variations I've tried:

This is generated from the record function:

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Documents and Settings\Scott\Desktop\Table.txt", Destination:=Range("A1"))
.Name = "Table"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "/"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
.Refresh BackgroundQuery:=False
End With

I then modified this code myself: BOLD is where I inserted the variables for the file

Dim FullPath As String, FilePath As String, Filename As String

'Get a text file name
FullPath = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Please selec text file...")

If strFullPath = "False" Then Exit Sub

'Splits FullPath into path and file name
Set oFSObj = CreateObject("SCRIPTING.FILESYSTEMOBJECT")

strFilePath = oFSObj.GetFile(strFullPath).ParentFolder.Path
strFilename = oFSObj.GetFile(strFullPath).Name

With ActiveSheet.QueryTables.Add(Connection:=FullPath, Destination:=Range("A1"))
.Name = Filename
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "/"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1)
.Refresh BackgroundQuery:=False
End With
End Sub

 

[Iridium]

A few options from my Personal.xls

Sub ImportLargeFile()
'Imports text file into Excel workbook using ADO.
'If the number of records exceeds 65536 then it splits it over more than one sheet.

    Dim strFilePath As String, strFilename As String, strFullPath As String
    Dim lngCounter As Long
    Dim oConn As Object, oRS As Object, oFSObj As Object

    'Get a text file name
    strFullPath = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Please select text file...")

    If strFullPath = "False" Then Exit Sub  'User pressed Cancel on the open file dialog

    'This gives us a full path name e.g. C:\temp\folder\file.txt
    'We need to split this into path and file name
    Set oFSObj = CreateObject("SCRIPTING.FILESYSTEMOBJECT")

    strFilePath = oFSObj.GetFile(strFullPath).ParentFolder.path
    strFilename = oFSObj.GetFile(strFullPath).Name


    'Open an ADO connection to the folder specified
    Set oConn = CreateObject("ADODB.CONNECTION")
    oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
               "Data Source=" & strFilePath & ";" & _
               "Extended Properties=""text;HDR=Yes;FMT=Delimited"""

    Set oRS = CreateObject("ADODB.RECORDSET")

    'Now actually open the text file and import into Excel
    oRS.Open "SELECT * FROM " & strFilename, oConn, 3, 1, 1
    While Not oRS.EOF
        Sheets.Add
        ActiveSheet.Range("A1").CopyFromRecordset oRS, 65536
    Wend

    oRS.Close
    oConn.Close

End Sub

Sub LargeFileImport()
'http://support.microsoft.com/default.aspx?scid=kb;en-us;120596
      'Dimension Variables
      Dim ResultStr As String
      Dim FileName As String
      Dim FileNum As Integer
      Dim Counter As Double
      'Ask User for File's Name
      FileName = InputBox("Please enter the Text File's name, e.g. test.txt")
      '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 Screen Updating Off
      Application.ScreenUpdating = False
      'Create A New WorkBook With One Worksheet In It
      Workbooks.Add Template:=xlWorksheet
      'Set The Counter to 1
      Counter = 1
      'Loop Until the End Of File Is Reached
      Do While Seek(FileNum) <= LOF(FileNum)
         'Display Importing Row Number 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
          'Store Variable Data Into Active Cell
          If Left(ResultStr, 1) = "=" Then
             ActiveCell.Value = "'" & ResultStr
          Else
             ActiveCell.Value = ResultStr
          End If
          
          'For xl97 and later change 16384 to 65536
          If ActiveCell.Row = 16384 Then
             'If On The Last Row Then Add A New Sheet
             ActiveWorkbook.Sheets.Add
          Else
             'If Not The Last Row Then Go One Cell Down
             ActiveCell.Offset(1, 0).Select
          End If
          'Increment the Counter By 1
          Counter = Counter + 1
      'Start Again At Top Of 'Do While' Statement
      Loop
      'Close The Open Text File
      Close
      'Remove Message From Status Bar
      Application.StatusBar = False

   End Sub

Sub LargeDatabaseImport()
'http://support.microsoft.com/default.aspx?scid=kb;en-us;272729
    '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

HTH

 

[ScottSmith]

Thanks for the help.

The microsoft one worked. Thanks!!!