Import Specific line from multiple text files

Hi,

I have many text files ~5000 and I am searching for a macro that can import multiple files and also search the text file only importing two specific rows (error files may will not have 42 rows) while listing the file name in an adjacent cell.

So in column A I would like the file name, in column B any data in line 42 of the text file and in column C any data in line 43 of the text file.

Here is an example of the data in rows 42 & 43:
11 Waratah Street Mona Vale(2103) - Australie
-33.68 (-33°40') | 151.30 (151°18')

So far I have found the code below that will import all text files into one sheet but it does not satisfy my requirements.

Is what I’m after possible?

Option Explicit
 
Sub OpenTextFiles()
    Dim strFiles() As String
    Dim strFName As String
    Dim strFPath As String
    Dim IntFile As Integer
    Dim sep As String
     'define the directory
    strFPath = "E:\Work Files 1\Mapping Sales Data\Importing Text Files Test\"
     
     'build a list of files
    strFName = Dir(strFPath & "*.txt")
    While strFName <> ""
        IntFile = IntFile + 1
        ReDim Preserve strFiles(1 To IntFile)
        strFiles(IntFile) = strFName
        strFName = Dir()
    Wend
     
     'see if any files were found
    If IntFile = 0 Then
         MsgBox "No files found"
        Exit Sub
    End If
    sep = InputBox("Enter a single delimiter character.", _
    " Import Text File")
     'cycle through the list and import
    For IntFile = 1 To UBound(strFiles)
        ImportTextFile strFPath & CStr(strFiles(IntFile)), sep
    Next
End Sub
Public Sub ImportTextFile(FName As String, sep As String)
     
    Dim RowNdx As Integer
    Dim ColNdx As Integer
    Dim TempVal As Variant
    Dim WholeLine As String
    Dim Pos As Integer
    Dim NextPos As Integer
    Dim SaveColNdx As Integer
     
    Application.ScreenUpdating = False
     'On  Error GoTo EndMacro:
     
    SaveColNdx = 1
    RowNdx = Range("A65536").End(xlUp).Row + 1
     
    Open FName For Input Access Read As #1
     
    While Not EOF(1)
        Line Input #1, WholeLine
        If Right(WholeLine, 1) <> sep Then
            WholeLine = WholeLine & sep
        End If
        ColNdx = SaveColNdx
        Pos = 1
        NextPos = InStr(Pos, WholeLine, sep)
        While NextPos >= 1
            TempVal = Mid(WholeLine, Pos, NextPos - Pos)
            Cells(RowNdx, ColNdx).Value = TempVal
            Pos = NextPos + 1
            ColNdx = ColNdx + 1
            NextPos = InStr(Pos, WholeLine, sep)
        Wend
        RowNdx = RowNdx + 1
    Wend
     
EndMacro:
    On Error GoTo 0
    Application.ScreenUpdating = True
    Close #1
     
End Sub

Did you write this code? (I ask because it seems you should be able to complete it if you did.)

You could use Split instead of the loop for parsing the line at sep.

I wish! No I have been just searching the net for code and found this one on some website. Unfortunately I have fairly low VBA skills and can only make small simple changes to code I find on the net...this problem is beyond my skills

Hi
Try the following macro.

Sub copy_text()
Dim a As Long, x As Long
Dim f As String, b As String
Cells(1, 1) = "=cell(""filename"")"
Cells(1, 2) = "=left(A1,find(""["",A1)-1)"
Range("A2:A1000").ClearContents
Cells(2, 1).Select
f = Dir(Cells(1, 2) & "*.txt")
Do While Len(f) > 0
ActiveCell.Formula = f
ActiveCell.Offset(2, 0).Select
f = Dir()
Loop
x = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "there are " & x - 1 & " files"
For a = 2 To x Step 2
b = Cells(a, 1)
Range("AA:AA").ClearContents
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Worksheets("sheet2").Cells(1, 2) & b _
        , Destination:=.Range("AA1"))
        .Name = "eiys"
        .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 = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .Refresh BackgroundQuery:=False
        End With
Range("AA42:AZ42").Copy
Range("B" & a).PasteSpecial
Range("AA43:AZ43").Copy
Range("B" & a + 1).PasteSpecial
Next a
MsgBox "Listing is complete."
End Sub

Ravi

Thanks but that macro just lists the file names

I had to remove "Destination:=.Range" the period between equals and range
and I also had to remove ".Refresh BackgroundQuery:=False" to get this macro to run.

Sub copy_text()
Dim a As Long, x As Long
Dim f As String, b As String
Cells(1, 1) = "=cell(""filename"")"
Cells(1, 2) = "=left(A1,find(""["",A1)-1)"
Range("A2:A1000").ClearContents
Cells(2, 1).Select
f = Dir(Cells(1, 2) & "*.txt")
Do While Len(f) > 0
ActiveCell.Formula = f
ActiveCell.Offset(2, 0).Select
f = Dir()
Loop
x = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "there are " & x - 1 & " files"
For a = 2 To x Step 2
b = Cells(a, 1)
Range("AA:AA").ClearContents
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Worksheets("sheet2").Cells(1, 2) & b, Destination:=Range("AA1"))
        .Name = "eiys"
        .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 = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        End With
Range("AA42:AZ42").Copy
Range("B" & a).PasteSpecial
Range("AA43:AZ43").Copy
Range("B" & a + 1).PasteSpecial
Next a
MsgBox "Listing is complete."
End Sub

Hi
The code is supposed to import text file into col AA and pick 42nd and 43rd line from there and delete earlier data before next file is called. It copies AA to AZ and pastes it against their file name.
Ravi

Sorry but it doesn't work.

Hello Vlad999,

This macro use the FileScriptingObject. Since the FSO is created at runtime, you don't need to add the library reference to your project to make it work. The macro checks that each file exists, and has at least 43 lines in it. It starts reading the file names at "A2" of the active sheet. You change this in the macro (look for the red code). The next column to the right holds line 42, and the next cell to right of that one holds line 43. Copy this code into a Standard VBA module.

Sub ReadLinesFromFile()

  Dim C As Long
  Dim FileName As String
  Dim FSO As Object
  Dim I As Long
  Dim LastRow As Long
  Dim LineText As String
  Dim R As Long
  Dim StartCol As Variant
  Dim StartRow As Long
  Dim TextFile As Object
  
  Const ForReading = 1
  Const TriStateDefault = -2
  
    StartCol = "A"
    StartRow = 2
  
      C = Cells(1, StartCol).Column
      LastRow = Cells(Rows.Count, C).End(xlUp).Row
    
        Set FSO = CreateObject("Scripting.FileSystemObject")
        
          For R = StartRow To LastRow
            FileName = Cells(R, C)
              If Dir(FileName) = "" Then
                MsgBox "File Not Found" & vnCrLf & "'" & FileName & "'"
                GoTo NextFile
              End If
            Set TextFile = FSO.OpenTextFile(FileName:=FileName, _
                                            IOMode:=ForReading, _
                                            Create:=False, _
                                            Format:=TriStateDefault)
             'Skip the first 41 lines in the file
              For I = 1 To 41
                If Not TextFile.AtEndOfStream Then
                  TextFile.SkipLine
                End If
              Next I
              
           'Copy lines 42 and 43 to the worksheet
            If Not TextFile.AtEndOfStream Then
              Cells(R, C + 1) = TextFile.ReadLine
              Cells(R, C + 2) = TextFile.ReadLine
            End If
            
            TextFile.Close
NextFile:
          Next R
          
    Set FSO = Nothing
    Set TextFile = Nothing
    
End Sub

Sincerely,
Leith Ross