Copy text files and their content into a single sheet

[Chris78]

Hi There,
I'm looking for macro that would read all text files from a specified folder (not subfolders).
The code should loop through all text files and complete 2 columns with filename and file content
column a: filename
column b: file content

I tried to start with a simple code below ... but guess I should use an FSO approach instead
Any recommendation or post page/post you could direct me to?

Sub TextImport()
Dim PathName As String
Dim FileNumber As Integer
Dim Textdata As String


'Path
PathName = "C:\FILE_LOCATION\database.txt"


FileNumber = FreeFile() 'Assigns the first available file number (E.g.: #1 )
Open PathName For Input As #FileNumber 'Open file in read mode


'Copy the contents to Worksheet ---
Textdata = Input(LOF(FileNumber), FileNumber) 'Loads all file contents into variable
Range("A1").Value = Application.Transpose(Textdata)
'----------------------------------
Close #FileNumber 'Closes the file (the number in FileNumber can be reused)
End Sub

 

[AlphaFrog]

Here's a free add-in that will do what you ask...

RDBMerge, Excel Merge Add-in

 

[DanteAmor]

Another approach

Change the data in red for your data.

Sub Copy_text_files()
  Dim sh As Worksheet, wPath As String, wFile As Variant, lr As Long
  Application.ScreenUpdating = False
  '
  Set sh = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]")
  wPath = "[COLOR=#ff0000]C:\FILE_LOCATION\[/COLOR]"
  wFile = Dir(wPath & "*.txt")
  '
  sh.Rows("2:" & Rows.Count).ClearContents
  Do While wFile <> ""
    Workbooks.OpenText Filename:=wPath & wFile, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
      TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, _
      Space:=False, Other:=False, FieldInfo:=Array(1, 2), TrailingMinusNumbers:=True
    lr = sh.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
    Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Copy sh.Range("B" & lr)
    sh.Range("A" & lr & ":A" & sh.Range("B" & Rows.Count).End(xlUp).Row).Value = wFile
    ActiveWorkbook.Close False
    wFile = Dir()
  Loop
  MsgBox "End  "
End Sub

 

[Chris78]

Thanks both for your responses. @DanteAmor
The code above works but actually generates multiple lines in the worksheet.
I am trying to get the complete text file in a single cell. The aim is to have one line per text file... with filename in A and complete content in B. Thanks again for your help.

 

[Legacy 98055]

I think your first idea using the files system object should work...

Sub ExampleHere()
    Dim r As Range
    Dim fso As New FileSystemObject
    Dim f As Folder
    Dim fi As File
    
    Set r = [a1]
    For Each fi In fso.GetFolder("C:\MyTextFiles").Files
        r = fi.Name 'Or fi.Path
        With fi.OpenAsTextStream
            r.Offset(, 1) = .ReadAll
            .Close
        End With
        Set r = r.Offset(1)
    Next
End Sub

 

[DanteAmor]

Thanks both for your responses. @DanteAmor
The code above works but actually generates multiple lines in the worksheet.
I am trying to get the complete text file in a single cell. The aim is to have one line per text file... with filename in A and complete content in B. Thanks again for your help.

I'm sorry, I understood differently. I vote for Tom Schreiner's solution.

 

[Chris78]

Thanks a ton both for your responses.
This is the code I ended up with - which I guess can be simplified but works fine for my purpose

Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim xFiDialog As FileDialog
Dim xPath As String
Dim FileName As String
Dim FineExtension As String

Dim LineTXT As String
Dim AllTXT As String

Dim i As Integer
Set xFiDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFiDialog.Show = -1 Then
xPath = xFiDialog.SelectedItems(1)
End If
Set xFiDialog = Nothing
If xPath = "" Then Exit Sub
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
ActiveSheet.Cells(1, 1) = "File name"
ActiveSheet.Cells(1, 2) = "File extension"
ActiveSheet.Cells(1, 3) = "File content"

i = 1
For Each xFile In xFolder.Files
AllTXT = ""
FileName = Left(xFile.Name, InStrRev(xFile.Name, ".") - 1)
FileExtension = Mid(xFile.Name, InStrRev(xFile.Name, ".") + 1)

If FileExtension = "txt" Or FileExtension = "kb" Or FileExtension = "html" Then
Open xPath & "" & xFile.Name For Input As #1
Do While Not EOF(1)
Line Input #1 , LineTXT
If LineTXT <> "" Then
AllTXT = AllTXT & vbCrLf & LineTXT
End If
Loop
Close #1
End If
i = i + 1
ActiveSheet.Cells(i, 1) = FileName
ActiveSheet.Cells(i, 2) = FileExtension
ActiveSheet.Cells(i, 3) = AllTXT
Next