VBA / Macro Help -Adding file name as column to existing Import Multiple Text File Macro

Hello All,

Appreciate help this forum and contributor provides.

I have existing macro (below) which combines (50+) multiple text file delimited via "|" from given folder and saves as as excel table. I want to add text file name to given record field in table so i know where I pulled this record from and which file it belongs to. Can this be done in this macro? I have to do this every day so this would help in validation.

Folder has multiple .txt file like below

I_CNNSR6_09112012.txt
E_CBSSR6_09122012.txt

I want to add file name as column field against the record from that file let say E_CBSSR6_09122012.txt file has following records (or multiple) pulled in table

Location|Product1 |38080090|7500|KGS|7510937.5
Location|Product2 |38081090| 500|KGS|751937.5

I want get this way in my table columns

Col A Col B Col C Col D Col E Col F Col G
Location Product1 38080090 7500 KGS 7510937.5 E_CBSSR6_09122012
Location Product2 38081090 500 KGS 751937.5 E_CBSSR6_09122012

Thanks
NKRA


Credit to following for following macro site http://www.rondebruin.nl/csv.htm

Macro

' Start Code

Declare Function OpenProcess Lib "kernel32" _
                             (ByVal dwDesiredAccess As Long, _
                              ByVal bInheritHandle As Long, _
                              ByVal dwProcessId As Long) As Long

Declare Function GetExitCodeProcess Lib "kernel32" _
                                    (ByVal hProcess As Long, _
                                     lpExitCode As Long) As Long

Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103


Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
    Dim hProg As Long
    Dim hProcess As Long, ExitCode As Long
    'fill in the missing parameter and execute the program
    If IsMissing(WindowState) Then WindowState = 1
    hProg = Shell(PathName, WindowState)
    'hProg is a "process ID under Win32. To get the process handle:
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
    Do
        'populate Exitcode variable
        GetExitCodeProcess hProcess, ExitCode
        DoEvents
    Loop While ExitCode = STILL_ACTIVE
End Sub


Sub Merge_CSV_Files()
    Dim BatFileName As String
    Dim TXTFileName As String
    Dim XLSFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim DefPath As String
    Dim Wb As Workbook
    Dim oApp As Object
    Dim oFolder
    Dim foldername

    'Create two temporary file names
    BatFileName = Environ("Temp") & _
            "\CollectCSVData" & Format(Now, "dd-mm-yy-h-mm-ss") & ".bat"
    TXTFileName = Environ("Temp") & _
            "\AllCSV" & Format(Now, "dd-mm-yy-h-mm-ss") & ".txt"

    'Folder where you want to save the Excel file
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Set the extension and file format
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007
        FileExtStr = ".xlsx": FileFormatNum = 51
        'If you want to save as xls(97-2003 format) in 2007 use
        'FileExtStr = ".xls": FileFormatNum = 56
    End If

    'Name of the Excel file with a date/time stamp
    XLSFileName = DefPath & "MasterCSV " & _
    Format(Now, "dd-mmm-yyyy h-mm-ss") & FileExtStr

    'Browse to the folder with CSV files
    Set oApp = CreateObject("Shell.Application")
    Set oFolder = oApp.BrowseForFolder(0, "Select folder with CSV files", 512)
    If Not oFolder Is Nothing Then
        foldername = oFolder.Self.Path
        If Right(foldername, 1) <> "\" Then
            foldername = foldername & "\"
        End If

        'Create the bat file
        Open BatFileName For Output As #1
        Print #1, "Copy " & Chr(34) & foldername & "*.txt" _
        & Chr(34) & " " & TXTFileName
        Close #1

        'Run the Bat file to collect all data from the CSV files into a TXT file
        ShellAndWait BatFileName, 0
        If Dir(TXTFileName) = "" Then
            MsgBox "There are no csv files in this folder"
            Kill BatFileName
            Exit Sub
        End If

        'Open the TXT file in Excel
        Application.ScreenUpdating = False
        Workbooks.OpenText Filename:=TXTFileName, Origin:=xlWindows, StartRow _
        :=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, _
        Space:=False, Other:=True, OtherChar:="|"

        'Save text file as a Excel file
        Set Wb = ActiveWorkbook
        Application.DisplayAlerts = False
        Wb.SaveAs Filename:=XLSFileName, FileFormat:=FileFormatNum
        Application.DisplayAlerts = True

        Wb.Close savechanges:=False
        MsgBox "You find the Excel file here: " & vbNewLine & XLSFileName

        'Delete the bat and text file you temporary used
        Kill BatFileName
        Kill TXTFileName

        Application.ScreenUpdating = True
    End If
End Sub

' End code

Try this:

Option Explicit

Sub Main_Import()

    Dim destinationSheet As Worksheet
    Dim FDfolder As FileDialog
    
    'Sheet1 is the name of the sheet into which the text files will be imported
    
    Set destinationSheet = Worksheets("Sheet1")
        
    Set FDfolder = Application.FileDialog(msoFileDialogFolderPicker)
    With FDfolder
        .Title = "Select folder containing text files to be imported"
        .AllowMultiSelect = False
        .Filters.Clear
        If .Show Then
            Import_Text_Files_in_Folder .SelectedItems(1), destinationSheet
        End If
    End With
    
End Sub


Private Sub Import_Text_Files_in_Folder(ByVal folder As String, destSheet As Worksheet)

    Dim textFile As String
    Dim row As Long, lr As Long
    Dim textWorkbook As Workbook

    destSheet.Cells.Clear
    row = 1
    
    If Right(folder, 1) <> "\" Then folder = folder & "\"
    textFile = Dir(folder & "*.txt")
    While textFile <> ""
        
        Workbooks.OpenText Filename:=folder & textFile, Origin:=xlWindows, StartRow:=1, _
            DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False, _
            Space:=False, Other:=True, OtherChar:="|"
        
        Set textWorkbook = ActiveWorkbook
        With textWorkbook.Worksheets(1)
            lr = .UsedRange.Rows.Count
            .Range("G1:G" & lr).Value = Left(textFile, InStr(textFile, ".") - 1)
            .UsedRange.Copy destSheet.Rows(row)
        End With
        textWorkbook.Close savechanges:=False
        row = row + lr
        
        textFile = Dir()
    Wend

End Sub

Use my code instead of your code. Press Alt+F11 in Excel to open the VB Editor, click Insert -> Module to create a new standard module, paste all my code into the white editor pane where the cursor is and run the Main_Import macro.

To stop the screen flickering, put:

Application.ScreenUpdating = False

at the start of Import_Text_Files_in_Folder

and:

Application.ScreenUpdating = True

at the end.


Your code creates a single file using DOS COPY *.txt singleFile.txt, and imports that single file into Excel, so it is bound to be quicker than importing text files one by one as my code does. However, I can't think of a way to get each file name into the associated records of the singleFile.txt created by DOS.

A slightly faster method would be to use a query table (Data - Import External Data - Import Data) to import each text file directly into the destination sheet, updating the destination cell for each file. Use the Macro Recorder to generate the code to get started with this method.