Multiple text file import including file name.

Hi All.

First post and certainly not the first problem. Thanks to google and some good coders so far (from another post on the site), I have got the following code.

Sub test()
    Dim myDir As String, fn As String, txt As String, n As Long
    Dim x, y, i As Long, ii As Long, flg As Boolean, a() As String
    Const delim As String = vbTab
    myDir = ThisWorkbook.Path & "\"
    fn = Dir(myDir & "*.txt")
    Do While fn <> ""
        txt = CreateObject("Scripting.FileSystemObject") _
        .OpenTextFile(myDir & fn).ReadAll
        x = Split(txt, vbLf)
        ReDim a(1 To UBound(x) + 1, 1 To 1000)
        For i = IIf(flg, 1, 0) To UBound(x)
            y = Split(x(i), delim)
            n = n + 1
            For ii = 0 To UBound(y)
                a(n, ii + 1) = y(ii)
            Next
        Next
        Sheets(1).Cells(Rows.Count, 2).End(xlUp)(2) _
        .Resize(n, UBound(a, 2)).Value = a
        
        
        n = 0: flg = True
        fn = Dir
    Loop
    Sheets(1).Rows(1).Delete
End Sub

This code imports and appends the new file at the bottom of the last one in column 2.. What I want to do is match each line with the filename of the text file being imported.

EG

File 1.txt

This
Is
Data

COL1 COL2
1.txt This
1.txt Is
1.txt Data

Any ideas?

Seems I wrote it a while back...

See if this is what you wanted

Sub test()
    Dim myDir As String, fn As String, txt As String, n As Long
    Dim x, y, i As Long, ii As Long, flg As Boolean, a() As String
    Const delim As String = vbTab
    myDir = ThisWorkbook.Path & "\"
    fn = Dir(myDir & "*.txt")
    Do While fn <> ""
        txt = CreateObject("Scripting.FileSystemObject") _
        .OpenTextFile(myDir & fn).ReadAll
        With CreateObject("VBScript.RegExp")
            .Global = True
            .MultiLine = True
            .Pattern = "([^\n]+$)"
            txt = .Replace(txt, fn & delim & "$1")
        End With
        x = Split(txt, vbLf)
        ReDim a(1 To UBound(x) + 1, 1 To 1000)
        For i = IIf(flg, 1, 0) To UBound(x)
            y = Split(x(i), delim)
            n = n + 1
            For ii = 0 To UBound(y)
                a(n, ii + 1) = y(ii)
            Next
        Next
        Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2) _
        .Resize(n, UBound(a, 2)).Value = a
        n = 0: flg = True
        fn = Dir
    Loop
    Sheets(1).Rows(1).Delete
End Sub

Originally Posted by jindon

Seems I wrote it a while back...

See if this is what you wanted

Gentlemen, Scholar and Lifesaver. Thankyou!