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

Important message to visitors of this page

Ron de Bruin decided to remove all Windows Excel content from his website for personal reasons. If you want to know why, head over to rondebruin.nl.

Luckily, Ron was kind enough to allow me to publish all of his Excel content here.

Most of these pages are slightly outdated and may contain links that don 't work. Please inform me if you find such an error and I'll try to fix it.

Kind regards

Jan Karel Pieterse

You can find code examples on my site to merge data from different workbooks into a new worksheet and also a add-in. But what if there are too many rows to copy into one worksheet. The code below will create a TXT file for you with the 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 in this macro. Important : Do not change anything In the other macro and function.

'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

Example code

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

Copy the code in a Standard module of your workbook, if you just started with VBA see this page.
Where do I paste the code that I find on the internet

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

Ron de BruinExcel Automation