Merge data from all workbooks in a folder to a txt file

Ron de Bruin (last update 30-June-2008)
Go back to the Excel tips page

You can find code on my site to merge data from different workbooks into a new worksheet.
But what if there are too many rows to copy into one worksheet?
The code below will create a TXT file for you with data from every workbook in a folder.
You can import this text file into a database for example if you want.

Before we can run the macro "Merge_Data_To_Text_File" we must change a few things.

'Path/Name of the txt file it will create
TextFileName = "C:\Users\Ron\Merge.txt"

'Fill in the path\folder where the Excel files are
MyPath = "C:\Users\Ron\test"

After we open each file in the folder in the loop we call the macro named RDB_ExportToTextFile
There are a few arguments that we can change.

FName : We not change this argument

SheetIndex : If you use 1. it will copy from the first worksheet

SheetName : The name of the worksheet where you want to copy from
If SheetName = "" it will use the SheetIndex

CopyRange : The range that you want to copy
If CopyRange = "" it will copy all data on the worksheet starting in FirstCell

FirstCell : If you use FirstCell:=A2 it will not copy the first row of the worksheet

Sep : Typically, this is vbTab, a space, a comma, semicolon, or pipe ( | ). Any character may be used.

    RDB_ExportToTextFile _
            FName:=TextFileName, _
            SheetIndex:=1, _
            SheetName:="", _
            CopyRange:="", _
            FirstCell:="A2", _
            Sep:=";", _
            AppendData:=True

The Code example

Copy the code below in a normal module and change the code lines I explain above.
Note: There are two macros and one Function.

If you have no idea where to paste the code then look here:
http://www.rondebruin.nl/code.htm

Sub Merge_Data_To_Text_File()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim TextFileName As String

    'Path/Name of the txt file it will create
    TextFileName = "C:\Users\Ron\Merge.txt"

    'Delete the txt file first if it exist
    On Error Resume Next
    Kill TextFileName
    On Error GoTo 0

    'Fill in the path\folder where the Excel files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

'Now we call the macro named RDB_ExportToTextFile
'There are a few arguments that we can change
'FName : We not change this argument
'SheetIndex : If you use 1. it will copy from the first worksheet
'SheetName : The name of the worksheet where you want to copy from
'If SheetName = "" it will use the SheetIndex
'CopyRange : The range that you want to copy
'If CopyRange = "" it will copy all data on the worksheet starting in FirstCell
'If you use FirstCell:=A2 it will not copy the first row of the worksheet
'Sep : Typically, this is vbTab, a space, a comma, semicolon, or pipe ( | ).
'Any character may be used.

                RDB_ExportToTextFile _
                        FName:=TextFileName, _
                        SheetIndex:=1, _
                        SheetName:="", _
                        CopyRange:="", _
                        FirstCell:="A2", _
                        Sep:=";", _
                        AppendData:=True

            End If
            mybook.Close savechanges:=False

        Next Fnum
    End If

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub


Sub RDB_ExportToTextFile(FName As String, SheetName As String, _
    SheetIndex As Long, CopyRange As String, FirstCell As String, _
    Sep As String, AppendData As Boolean)
'Original code from Chip Pearson
'http://www.cpearson.com/excel/ImpText.aspx
'Changed by Ron de Bruin on 29-June-2008

    Dim WholeLine As String
    Dim Fnum As Long
    Dim RowNdx As Long
    Dim ColNdx As Long
    Dim StartRow As Long
    Dim EndRow As Long
    Dim StartCol As Long
    Dim EndCol As Long
    Dim CellValue As String
    Dim rng As Range
    Dim SourceWorksheet As Worksheet

    On Error GoTo EndMacro:

    Fnum = FreeFile

    If SheetName = "" Then
        Set SourceWorksheet = Worksheets(SheetIndex)
    Else
        Set SourceWorksheet = Worksheets(CStr(SheetName))
    End If

    If CopyRange <> "" Then
        Set rng = SourceWorksheet.Range(CopyRange)
    Else
        If RDB_Last(1, SourceWorksheet.Cells) < _
           SourceWorksheet.Range(FirstCell).Row Then
            Set rng = Nothing
        Else
            Set rng = SourceWorksheet.Range(FirstCell & ":" _
                        & RDB_Last(3, SourceWorksheet.Cells))
        End If
    End If

    If Not rng Is Nothing Then

        With rng
            StartRow = .Cells(1).Row
            StartCol = .Cells(1).Column
            EndRow = .Cells(.Cells.Count).Row
            EndCol = .Cells(.Cells.Count).Column
        End With

        If AppendData = True Then
            Open FName For Append Access Write As #Fnum
        Else
            Open FName For Output Access Write As #Fnum
        End If

        With SourceWorksheet
            For RowNdx = StartRow To EndRow
                WholeLine = ""
                For ColNdx = StartCol To EndCol
                    If .Cells(RowNdx, ColNdx).Value = "" Then
                        CellValue = Chr(34) & Chr(34)
                    Else
                        CellValue = .Cells(RowNdx, ColNdx).Text
                    End If
                    WholeLine = WholeLine & CellValue & Sep
                Next ColNdx
                WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
                Print #Fnum, WholeLine
            Next RowNdx
        End With
    End If

EndMacro:
    On Error GoTo 0
    Close #Fnum

End Sub


Function RDB_Last(choice As Long, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
    Dim lrw As Long
    Dim lcol As Long

    Select Case choice

    Case 1:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
        On Error GoTo 0

    Case 2:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
        On Error GoTo 0

    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       after:=rng.Cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0

        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        after:=rng.Cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0

        On Error Resume Next
        RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            RDB_Last = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0

    End Select
End Function