Copy data from multiple txt files in one single Excel

[1Ronin]

Hello,

I'm new on this forum and I need a macro to help me to copy the values from multiple "txt" files into a single Excel file.
The details are:
- I have many "txt" files (could be hundreds or thousands)
- the files names are similar to: 1715900115406111-30062017111747.10007-tor (it's a txt file, despite the strange extension!)
- each txt file can have thousands of rows; number of rows can be different from file to file
- each row has 2 groups of values delimited by semicolon; an example: 0.010;0.885
- interested data are in the 2nd group
- all files are in the same folder
What I need:
- make/open a Master file (Excel)
- Master file can be in the same folder with txt files or not
- open first txt file
- convert txt -> columns
- copy txt file name to 1st row in Master; for example: A1 = 1715900115406111
- copy txt file date to 2nd row in Master; for example: A2 = 30.06.2017
- copy txt file hour to 3rd row in Master; for example: A3 = 11:17:47
- copy txt file station number to 4th row in Master; for example: A4 = 10007
- copy all data from txt file column "B" starting with row 5, below the station number; for example: A5:A14560
- do the same thing for all files in the next columns...

I have almost no knowledge about VB so in need a little help on this . I make same small macros, but nothing like this.
If I have 5-10 txt files I can do it manually, but for hundreds of files is not possible.

Please help me with a macro.
Thanks a lot.

 

[Warship]

Save the Workbook in the same Directory as your TextFiles.
No other files should be in the Directory except WB and TextFiles.

Sub ProcessTextFiles()
    Dim f, fls, FilePath As String, InputLine As String
    Dim Fi As String, Da As String, Ti As String, St As String
    Dim sh As Worksheet, r As Long, c As Long, FNum As Integer
    Dim CalculaSave As XlCalculation, ScrnUpdSave As Boolean
    Dim DisAlrtSave As Boolean, EnEventSave As Boolean
    
    CalculaSave = Application.Calculation
    ScrnUpdSave = Application.ScreenUpdating
    DisAlrtSave = Application.DisplayAlerts
    EnEventSave = Application.EnableEvents
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    Set sh = Worksheets(2) 'adjustment needed
    
    FilePath = ThisWorkbook.Path & "\"
    Set fls = GetAllFiles(FilePath)
    For Each f In fls
        Fi = Replace(Split(f, "-")(0), FilePath, "")
        Da = Left(Split(Split(f, "-")(1), ".")(0), 8)
        Da = Left(Da, 2) & "." & Mid(Da, 3, 2) & "." & Right(Da, 4)
        Ti = Mid(Split(Split(f, "-")(1), ".")(0), 9)
        Ti = Left(Ti, 2) & ":" & Mid(Ti, 3, 2) & ":" & Right(Ti, 2)
        St = Split(Split(f, "-")(1), ".")(1)
        c = c + 1
        r = 1
        sh.Cells(r, c) = "'" & Fi
        r = r + 1
        sh.Cells(r, c) = Da
        r = r + 1
        sh.Cells(r, c) = Ti
        r = r + 1
        sh.Cells(r, c) = "'" & St
        FNum = FreeFile
        Open f For Input Access Read As #FNum 
        Do Until EOF(FNum)
            Line Input #FNum , InputLine
            r = r + 1
            sh.Cells(r, c) = Split(InputLine, ";")(1)
        Loop
        Close FNum
    Next f
    
    Application.Calculation = CalculaSave
    Application.ScreenUpdating = ScrnUpdSave
    Application.DisplayAlerts = DisAlrtSave
    Application.EnableEvents = EnEventSave
End Sub

Private Function GetAllFiles(fPath As String, Optional fPattern As String = "") As Collection
    Dim gaf As New Collection, f
    If Right(fPath, 1) <> "" Then fPath = fPath & ""
    f = Dir(fPath & fPattern)
    Do While Len(f) > 0
        If Not f = ThisWorkbook.Name Then gaf.Add fPath & f
        f = Dir()
    Loop
    Set GetAllFiles = gaf
End Function

 

[1Ronin]

Hello Warship,


First of all... a big thank you for support.

Now, regarding the results of macro:
- I put all my TXT files (only 20 for tests) in the same folder
- I make in the same folder a file "Master.xlsm" to copy all data inside
- I copy the macro and run...
- One error "Run-time error 9: Subscript out of range" and macro stops at line 29:
St = Split(Split(f, "-")(1), ".")(1)

On line 19 you have a comment that say adjustment are needed. Can be more specific?
What I'm doing wrong?


Many thanks,

 

[Warship]

The adjustment: change Worksheets(2) to Worksheets("Sheet1") to extract data to the Worksheet named Sheet1.

as for the subscript error:
This tells me that the name of the file does not match the pattern you previously provided.
1715900115406111-30062017111747.10007-tor
The code relies on the dashes(-) and dots(.) to split the name.
It is specifically looking for: [file name]-[date&time].[station]-(the rest is ignored)

If you have multiple patterns we will address differently but I will need to see all possible ways the file might be named.

First let’s be sure what you have so far does work.
Try the error producing file by itself but first rename it to the above example.
If that works, then the file’s original name doesn’t match this pattern.
If possible, reply here with the error producing file’s original name.

 

[1Ronin]

I make a new folder with only one TXT file inside named as above (pattern) and the master file.
Same error:

[/IMG]
I have the error also if i try with all files.

The name of TXT files are different for each one. See an example below:

[/IMG]

 

[Warship]

I stand corrected , your file names appear correct.

Again with just a single textfile comment out (by putting a ' in front of it) the erroring line.
what are your results?

 

[1Ronin]

Hi,

I comment line 29 as you suggest. Macro work now, just have some strange values for first 3 rows. See below example:

A1 = path of files, but not complete
A2 = E.ur.o6\C
A3 = od:e :11

I will try more tomorrow to tweak a little the macro for these lines to be Ok and give you a new feed-back.
Any way we have the values...

​

Thanks a lot,

 

[Warship]

It looks like our FileNames are not being gathered correctly
Put this in the same Module then run it.
Does it list the FilePath\FileNames correctly?

Sub ListTextFiles()
    Dim f, fls, FilePath As String, sh As Worksheet, r As Long
    Set sh = ActiveSheet 'Worksheets("Sheet1")
    
    FilePath = ThisWorkbook.Path & "\"
    Set fls = GetAllFiles(FilePath)
    For Each f In fls
        r = r + 1
        sh.Cells(r, 1) = f
    Next f
End Sub

 

[Warship]

replace all previous code with:

Sub ProcessTextFiles()
    Dim f, fls, FilePath As String, InputLine As String
    Dim Fi As String, Da As String, Ti As String, St As String
    Dim sh As Worksheet, r As Long, c As Long, FNum As Integer
    Dim CalculaSave As XlCalculation, ScrnUpdSave As Boolean
    Dim DisAlrtSave As Boolean, EnEventSave As Boolean
    
    CalculaSave = Application.Calculation
    ScrnUpdSave = Application.ScreenUpdating
    DisAlrtSave = Application.DisplayAlerts
    EnEventSave = Application.EnableEvents
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    Set sh = Worksheets("Sheet1")
    
    FilePath = ThisWorkbook.Path & "\"
    Set fls = GetAllFiles(FilePath)
    For Each f In fls
        Fi = Split(f, "-")(0)
        Da = Left(Split(Split(f, "-")(1), ".")(0), 8)
        Da = Left(Da, 2) & "." & Mid(Da, 3, 2) & "." & Right(Da, 4)
        Ti = Mid(Split(Split(f, "-")(1), ".")(0), 9)
        Ti = Left(Ti, 2) & ":" & Mid(Ti, 3, 2) & ":" & Right(Ti, 2)
        St = Split(Split(f, "-")(1), ".")(1)
        c = c + 1
        r = 1
        sh.Cells(r, c) = "'" & Fi
        r = r + 1
        sh.Cells(r, c) = Da
        r = r + 1
        sh.Cells(r, c) = Ti
        r = r + 1
        sh.Cells(r, c) = "'" & St
        FNum = FreeFile
        Open FilePath & f For Input Access Read As #FNum 
        Do Until EOF(FNum)
            Line Input #FNum , InputLine
            r = r + 1
            sh.Cells(r, c) = Split(InputLine, ";")(1)
        Loop
        Close FNum
    Next f
    
    Application.Calculation = CalculaSave
    Application.ScreenUpdating = ScrnUpdSave
    Application.DisplayAlerts = DisAlrtSave
    Application.EnableEvents = EnEventSave
End Sub

Private Function GetAllFiles(fPath As String, Optional fPattern As String = "") As Collection
    Dim gaf As New Collection, f
    If Right(fPath, 1) <> "" Then fPath = fPath & ""
    f = Dir(fPath & fPattern)
    Do While Len(f) > 0
        If Not f = ThisWorkbook.Name Then gaf.Add f
        f = Dir()
    Loop
    Set GetAllFiles = gaf
End Function

 

[1Ronin]

Hi Warship,


Works perfect now.
Many thanks for your support.

​

Best regards,