Import Folder with TXT files to Excel

[emukiss10]

Hi guys!

I've been searchig for hours and cannot get answer how to do it..

I like VBA that ask me to choose folder and than Imports all contents of all TXT files to one sheet.

best regards
W.

 

[becci.gott]

Do they all have the same layout?

 

[emukiss10]

yes, just different data.

I want every line to be imported to one cell. No Text to Column thing. Just 1 line = 1 cell (A1 down)

 

[becci.gott]

Hopefully this will work for you.

It allows the user to select the file that contains the text files, imports them all into one sheet and then saves in the same location...

Before you run, you need to add the Microsoft Scripting Runtime references to the project.. In the VBA window, go to Tools > References

Sub ImportTextFiles()

Dim strFile, sItem As String
Dim tempwb, tgtwb As Workbook
Dim ws As Worksheet
Dim fldr As FileDialog
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File


With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With


'Identify which directory the files are in


Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    .Show
    sItem = .SelectedItems(1)
End With


Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(sItem)


'Create new workbook for import
Set tgtwb = Workbooks.Add


'Create worksheet for imports to be loaded into
Set ws = Sheets.Add(before:=tgtwb.Sheets(1))
ws.Name = "Import"


'Loop through all text files
For Each FileItem In SourceFolder.Files


    If Right(FileItem.Path, 4) = ".txt" Then
    
        'Identify file location and name
        strFile = FileItem.Path
        
        'Open file into temporary workbook
        Workbooks.OpenText Filename:=strFile, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote
        
        Set tempwb = ActiveWorkbook
        
        'Copy data from temp workbook
        With tempwb.Sheets(1).Range("A1", Range("A1").End(xlDown))
            .Select
            .Copy
        End With
        
        'Activate target workbook
        tgtwb.Activate
        
        'Paste data into bottom of the sheet
        With ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0)
        
            If .Row > 2 Then
                .PasteSpecial xlPasteAll
            Else
                .Offset(-1, 0).PasteSpecial xlPasteAll
            End If
        
        End With
        
        'Close temporary workbook
        tempwb.Close


    End If
    
Next FileItem


'Save targetworkbook (using directory of the text files)
tgtwb.SaveAs (sItem & "\Text file imports " & Format(Date, "yyyymmdd") & ".xlsx")




End Sub

 

[emukiss10]

Works Fine. Thank You!

 

[becci.gott]

Thanks for the feedback. Glad to have helped.