Import one column in many txt files in to one excel sheet

Hi everybody,

I am one problem with importing txt files into excel sheet. I hope everybody can help me. I have many txt files with similar content. Each txt file has 3 columns and I want to import only 1 column (the centered one) of each txt file into one comlumn in excel. All of columns in excel should be in one sheet. I tried to figure out in the forum but I could not find any problem like this. I attach one txt file for example.

Thank you very much for everybody's help.

Maybe this can get you started. Change path to yours.

Sub nhatruong306()

    Workbooks.OpenText Filename:="C:\YOUR PATH\data\YOUR FOLER\t1_300nm_0.001.txt", Origin _
        :=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
        Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), TrailingMinusNumbers _
        :=True
    ActiveWorkbook.SaveAs Filename:="C:\YOUR PATH\data\YOUR FOLER\t1_300nm_0.001.xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    Columns("B:B").ColumnWidth = 17.14
    Columns("B:B").NumberFormat = "0.0000000000"
    Columns("A:A").Delete Shift:=xlToLeft
    Columns("B:B").Delete Shift:=xlToLeft
    ActiveWorkbook.Save
    
End Sub

Thank you very much. But it works with only one txt file. Could I import many txt files into only one excel sheet ? Because I have hundreds of txt files, so that it is difficult to do it one by one. Thank you very much.

Try this

Sub test()
    Dim myDir As String, fn As String
    Dim txt As String, x, i As Long, t As Long
    Const delim As String = vbTab
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            myDir = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    fn = Dir(myDir & "\*.txt")
    Do While fn <> ""
        If FileLen(fn) Then
            t = t + 1
            txt = CreateObject("Scripting.FileSystemObject") _
            .OpenTextFile(myDir & "\" & fn).ReadAll
            x = Split(txt, vbCrLf)
            For i = 0 To UBound(x)
                If x(i) Like "*" & delim & "*" Then
                    x(i) = Split(x(i), delim)(1)
                End If
            Next
            With Sheets(1).Cells(1, t)
                .Value = fn
                With .Offset(1).Resize(UBound(x) + 1)
                    .NumberFormat = "@"
                    .Value = Application.Transpose(x)
                End With
            End With
        End If
        fn = Dir
    Loop
End Sub

When I pressed Alt+F8, I could not browse any txt files. Could you please help me to check it again? Thank you very much for your help.

It's a Folder picker, not a File picker.

The code will do the job with all the txt files in that folder.

1.jpg2.jpg
I tried with the folder but it still does not work. It showed some error as in the pictures. Could you explain in details ? I am not good at excel so that I apologize for bad question or steps. Thank you very much.

Are you sure that you are running my code?

My code should not produce such error.....

Try the attached.
Just select the folder when Folder picker comes up and click "OK".

I try again your code even with another computer, however it still shows that kind of error (error 53).

Could be some thing wrong with my software ?

Could you try again with my txt files? (attached file)

Attached are the files.

test with code.xlsm has result.

Thank you very much. I found what the problem is. In the code I should change something and it works well.

Sub Truong()
    Dim myDir As String, fn As String
    Dim txt As String, x, i As Long, t As Long
    Const delim As String = vbTab
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            myDir = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    fn = Dir(myDir & "\*.txt")
    Do While fn <> ""
        If FileLen(fn) Then
            t = t + 1
            txt = CreateObject("Scripting.FileSystemObject") _
            .OpenTextFile(myDir & "\" & fn).ReadAll
            x = Split(txt, vbCrLf)
            For i = 0 To UBound(x)
                If x(i) Like "*" & delim & "*" Then
                    x(i) = Split(x(i), delim)(1)
                End If
            Next
            With Sheets(1).Cells(1, t)
                .Value = fn
                With .Offset(1).Resize(UBound(x) + 1)
                    .NumberFormat = "@"
                    .Value = Application.Transpose(x)
                End With
            End With
        End If
        fn = Dir
    Loop
End Sub

Replace the red one by blue one

Sub Truong()
    Dim myDir As String, fn As String
    Dim txt As String, x, i As Long, t As Long
    Const delim As String = vbTab
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            myDir = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    fn = Dir(myDir & "\*.txt")
    Do While fn <> ""
        If FileLen(myDir & "\" & fn) Then
            t = t + 1
            txt = CreateObject("Scripting.FileSystemObject") _
            .OpenTextFile(myDir & "\" & fn).ReadAll
            x = Split(txt, vbCrLf)
            For i = 0 To UBound(x)
                If x(i) Like "*" & delim & "*" Then
                    x(i) = Split(x(i), delim)(1)
                End If
            Next
            With Sheets(1).Cells(1, t)
                .Value = fn
                With .Offset(1).Resize(UBound(x) + 1)
                    .NumberFormat = "@"
                    .Value = Application.Transpose(x)
                End With
            End With
        End If
        fn = Dir
    Loop
End Sub

Anyway, I would like to thank you very much for your help.

Ahhh, it should...

Good effort and mark the thread as "Solved", if it does what you wanted.