VBA Code to import multiple text files from subfolders into a single excel sheet

Question

Hello Everyone,

I want to import contents from multiple text files from subfolders into a single excel worksheet.

I am not sure which is the best way to do it.  I guess, VBA code can do it.  I don't know much about VBA code writing other than beginner level editing to suit my needs.

I do not want VBA code to do any parsing, I just need to get the contents of text files in single excel sheet without parsing/splitting.

Can anyone provide me a VBA code to achieve this task? 

Appreciate all your help.

Thanks,

Manuvendran

Answer 1

Hi,

try this....

Option Explicit

Sub Demo()

    Dim fso As Object 'FileSystemObject

    Dim fldStart As Object 'Folder

    Dim fld As Object 'Folder

    Dim fl As Object 'File

    Dim Mask As String

Application.ScreenUpdating = False

Dim newWS As Worksheet

Set newWS = Sheets.Add(before:=Sheets(1))

    Set fso = CreateObject("scripting.FileSystemObject") ' late binding

    'Set fso = New FileSystemObject 'or use early binding (also replace Object types)

    Set fldStart = fso.GetFolder**("C:\Folder1") ' <-- use your FileDialog code here**    Mask = "*.txt"

    'Debug.Print fldStart.Path & ""

    ListFiles fldStart, Mask

    For Each fld In fldStart.SubFolders

        ListFiles fld, Mask

        ListFolders fld, Mask

    Next

Dim myWB As Workbook, WB As Workbook

Set myWB = ThisWorkbook

Dim L As Long, t As Long, i As Long

L = myWB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row

t = 1

For i = 1 To L

Workbooks.OpenText Filename:=myWB.Sheets(1).Cells(i, 1).Value, DataType:=xlDelimited, Tab:=True

Set WB = ActiveWorkbook

WB.Sheets(1).UsedRange.Copy newWS.Cells(t, 2)

t = myWB.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1

WB.Close False

Next

myWB.Sheets(1).Columns(1).Delete

Application.ScreenUpdating = True

End Sub

Sub ListFolders(fldStart As Object, Mask As String)

    Dim fld As Object 'Folder

    For Each fld In fldStart.SubFolders

        'Debug.Print fld.Path & ""

        ListFiles fld, Mask

        ListFolders fld, Mask

    Next

End Sub

Sub ListFiles(fld As Object, Mask As String)

Dim t As Long

    Dim fl As Object 'File

    For Each fl In fld.Files

        If fl.Name Like Mask Then

        t = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1

            'Debug.Print fld.Path & "" & fl.Name

            If Sheets(1).Cells(1, 1) = "" Then

            Sheets(1).Cells(1, 1) = fld.Path & "" & fl.Name

            Else

            Sheets(1).Cells(t, 1) = fld.Path & "" & fl.Name

            End If

        End If

    Next

End Sub

XXXXXXXXXXXXXXXXXXXXXX

Note

the basic idea, 99.99% is from here..

http://stackoverflow.com/questions/14245712/cycle-through-sub-folders-and-files-in-a-user-specified-root-directory

Answer 2

Hi,

i'm using xl 2003

and there is no problem (in both macros)

try this,

using dim....

Sub macro_02()

'tested in xl2003

'export data in a new sheet

Dim fs As FileSearchSet fs = Application.FileSearchDim myWB As Workbook, WB As Workbook

Dim newSh As Worksheet

Dim N As Long, L As Long

Set myWB = ThisWorkbook

Application.ScreenUpdating = False

L = 1

Set newSh = myWB.Sheets.Add

With fs.Filename = "*.txt"

.LookIn = "C:\Folder1"  '<<< folders and subfolders into Folder1, change path

.SearchSubFolders = True

.Execute

For N = 1 To .FoundFiles.Count

Workbooks.OpenText Filename:=.FoundFiles.Item(N), DataType:=xlDelimited, Tab:=True

Set WB = ActiveWorkbook

WB.Sheets(1).UsedRange.Copy newSh.Cells(L, 1)

L = newSh.UsedRange.Rows.Count + 1

WB.Close False

Next

End With

myWB.Save

Application.ScreenUpdating = True

End Sub

Answer 3

Hi TasosK,

Thanks for your reply.

However this solution doesn't work for me.  I use Microsoft Excel 2010.

When I run this code, an error message pops up "Run-time error '445': Object doesn't support this action".

I clicked on 'Debug' button which highlighted "With Application.FileSearch" line in the VB script editor screen.

Please advise.

Thanks,

Manuvendran

Answer 4

Hi,

try this code...

[Edit]

Sub macro_01()

'tested in xl2003

'export data in a new sheet

Dim myWB As Workbook, WB As Workbook

Dim newSh As Worksheet

Dim N As Long, L As Long

Set myWB = ThisWorkbook

Application.ScreenUpdating = False

L = 1

Set newSh = myWB.Sheets.Add

With Application.FileSearch

.Filename = "*.txt"

.LookIn = "C:\Folder1"  '<<< folders and subfolders into Folder1, change path.SearchSubFolders = True

.Execute

For N = 1 To .FoundFiles.Count

Workbooks.OpenText Filename:=.FoundFiles.Item(N), DataType:=xlDelimited, Tab:=True

Set WB = ActiveWorkbook

**WB.Sheets(1).UsedRange.Copy newSh.Cells(L, 1)**L = newSh.UsedRange.Rows.Count + 1

WB.Close False

Next

End With

myWB.Save

Application.ScreenUpdating = True

End Sub