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