VBA Excel Macro to merge csv files & add folder and file name

[Vestyak]

Hi all, can you help me please to solve this problem? I have set of csv files in one file. To merge the content of this files and then split text to columns I use this script that I found in another thread (see below). It works great but..

I have new problem. I have this csv files In folders, not all in one folder (as before). I have to do the same operation - merge content of csv files from folders. But I also must to add 2 new columns - one with name of folder and second with name of file. Any idea please?

Eg. files
Gender
Male
Female

Eg. table[TABLE="width: 500"]
[TR]
[TD]id[/TD]
[TD]samp[/TD]
[TD]folder_name[/TD]
[TD]file_name[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]asd[/TD]
[TD]Gender[/TD]
[TD]Male[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]asd[/TD]
[TD]Gender[/TD]
[TD]Female[/TD]
[/TR]
[/TABLE]

Sub ImportCSV()
 
    Dim strSourcePath As String
    Dim strDestPath As String
    Dim strFile As String
    Dim strData As String
    Dim x As Variant
    Dim Cnt As Long
    Dim r As Long
    Dim c As Long
 
    Application.ScreenUpdating = False
 
    'Change the path to the source folder accordingly
    strSourcePath = "C:\Users\vlastimil.kovarik\Desktop\SOUR_TABLE"
 
    If Right(strSourcePath, 1) <> "" Then strSourcePath = strSourcePath & ""
 
    'Change the path to the destination folder accordingly
    strDestPath = "C:\Users\vlastimil.kovarik\Desktop\SOUR_TABLE"
 
    If Right(strDestPath, 1) <> "" Then strDestPath = strDestPath & ""
 
    strFile = Dir(strSourcePath & "*.csv")
 
    Do While Len(strFile) > 0
        Cnt = Cnt + 1
        If Cnt = 1 Then
           r = 1
       Else
           r = Cells(Rows.Count, "A").End(xlUp).Row + 1
       End If
        Open strSourcePath & strFile For Input As #1
            If Cnt > 1 Then
               Line Input #1, strData
           End If
            Do Until EOF(1)
                Line Input #1, strData
                x = Split(strData, ",")
                For c = 0 To UBound(x)
                    Cells(r, c + 1).Value = Trim(x(c))
                Next c
                r = r + 1
            Loop
        Close #1
        Name strSourcePath & strFile As strDestPath & strFile
        strFile = Dir
        
        'Range("G1").Select
        'ActiveSheet.PageSetup.CenterFooter = _
        'ActiveWorkbook.FullName
    Loop
 
    Application.ScreenUpdating = True
 
    If Cnt = 0 Then _
        MsgBox "No CSV files were found...", vbExclamation
        
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=";", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True
        
End Sub

Thank You very much!

V

 

[Vestyak]

Thread where I used script from - Thank you Domenic!
http://www.mrexcel.com/forum/excel-...e-all-new-csvs-folder-into-one-worksheet.html