VBA Excel - Importing multiple .txt files into the opened workbook then create one worksheet for each imported TXT file

Hello,

I need your help in order to create a macro that will do the following:

I have around 15 TXT files to import (comma or tab delimited) in a workbook and I would like, by a simple click on a macro button, to create a new worksheet at the end of the opened workbook then import the TXT file,  The new worksheet name would be the TXT file name.  It will repeat the same step (create new worksheet then import TXT file) until all .TXT files have been imported in the workbook.

The workbook and the TXT files are in the same network folder.  The workbook already contains worksheets that need to manipulate the new imported data.

I am totally new to VBA Excel

Thanks for you help,
mldaigle1Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

byundtMechanical EngineerCommented:
Here is a macro that will import data from every .txt file in the same folder as the workbook containing the macro. Each .txt file will be copied into a new worksheet in the workbook, named after the .txt file.
Sub TxtImporter()
Dim f As String, flPath As String
Dim i As Long, j As Long
Dim ws As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
flPath = ThisWorkbook.Path & Application.PathSeparator
i = ThisWorkbook.Worksheets.Count
j = Application.Workbooks.Count
f = Dir(flPath & "*.txt")
Do Until f = ""
    Workbooks.OpenText flPath & f, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
        Space:=False, Other:=False, TrailingMinusNumbers:=True
    Workbooks(j + 1).Worksheets(1).Copy After:=ThisWorkbook.Worksheets(i)
    ThisWorkbook.Worksheets(i + 1).Name = Left(f, Len(f) - 4)
    Workbooks(j + 1).Close SaveChanges:=False
    i = i + 1
    f = Dir
Loop
Application.DisplayAlerts = True
End Sub

Open in new window

0
mldaigle1Author Commented:
thanks for the code.  I did copy this in a new module in the workbook (this workbook already contains few worksheet, create a the end a new worksheet call "Generate Report", that will contain many macro buttons), create a button and try to run it.  

I got the error message : "Run-time error '1004'; Excel cannot insert the sheets into the destination workbook, because it contains fewer rows and columns than the source workbook...."

When I press the button "End" on the error message, it's opening the first TXT file into a new workbook instead of adding a new worksheet in the opened workbook.

When I press "Debug", the following line is highlighted :
   Workbooks(j + 1).Worksheets(1).Copy After:=ThisWorkbook.Worksheets(i)

Did i do something wrong when i copied the code into the Excel file?
0
byundtMechanical EngineerCommented:
I believe your master workbook (with the macro) was saved with .xls file extension, which means its worksheets only contain 65,536 rows. When you were testing the macro, it opened the .txt file as an Excel workbook in .xlsx file format. Such a file has 1,048,576 rows in its worksheets. Not surprisingly, Excel complained when you tried to copy the .txt file worksheet over to your master workbook.

Fortunately, the workaround is simple: save the master workbook in .xlsm (or .xlsb) file format rather than .xls. That will allow its worksheets to have 1,048,576 rows just like the .txt file workbook.

Brad
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
JavaScript Best Practices

Save hours in development time and avoid common mistakes by learning the best practices to use for JavaScript.

mldaigle1Author Commented:
Brad!!  Send you a big kiss!

Simple as you said... saved it as xlsm and it worked!!
0
byundtMechanical EngineerCommented:
I've answered a lot of questions on this forum, and been thanked in many different ways--but never with a kiss...    (blush)

I hope that you ask more questions in the future. Only three questions since 2011 means that you aren't getting as much out of the service as we have to offer.

Brad

A follow-up question by another person wanted to append .prn files in subfolders (requires FileSystemObject and recursive search), then produce a Summary worksheet. The required code is:
Dim FSO As Object

Sub RecursiveFileFinder()
'Finds files of a specified name pattern within a user-specified folder and its subfolders. Uses recursion. _
    Appends the first worksheet of those files after the last worksheet in workbook wbDest
Dim sFirstNamePattern As String, sNamePattern As String, TopFolderName As String
Dim TopFolderObj As Object
Dim celHome As Range
Dim wbDest As Workbook

Set wbDest = ActiveWorkbook     'Append copied worksheets here
Set celHome = ActiveCell
sFirstNamePattern = "*.*"       'Start with parent folder containing files of any type *.*
sNamePattern = "*.prn"          'Find just prn files *.prn*

TopFolderName = Application.GetOpenFilename("Files (" & sFirstNamePattern & "), " & sFirstNamePattern, _
        Title:="Pick any file in desired parent folder, then click Open")
If TopFolderName = "False" Then Exit Sub
TopFolderName = Left(TopFolderName, InStrRev(TopFolderName, Application.PathSeparator) - 1)

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TopFolderObj = FSO.GetFolder(TopFolderName)

SubFolderRecursion wbDest, TopFolderObj, sNamePattern
Set FSO = Nothing

MakeSummarySheet wbDest

Application.Goto celHome
Application.DisplayAlerts = True
Application.EnableEvents = True
'MsgBox "Done"
End Sub

Sub SubFolderRecursion(wbDest As Workbook, OfFolder As Object, sNamePattern As String)
'Loop recursively through each subfolder in OfFolder, looking for files whose name matches sNamePattern _
    When found, sub PRNimporter (called by sub SearchFolder) will append the first worksheet of that file to end of workbook wbDest
Dim SubFolder As Object
SearchFolder wbDest, OfFolder.Path, sNamePattern
For Each SubFolder In OfFolder.SubFolders
    SubFolderRecursion wbDest, SubFolder, sNamePattern
    SearchFolder wbDest, SubFolder.Path, sNamePattern
    'On Error Resume Next
    'If Dir(SubFolder.Path & Application.PathSeparator & "*.*") = "" Then RmDir SubFolder.Path      'Delete the subfolder if it is empty
    'On Error GoTo 0
Next SubFolder
End Sub
    
Sub SearchFolder(wbDest As Workbook, strPath As String, sNamePattern As String)
'In folder at strPath, looking for files whose name matches sNamePattern _
    When found, sub PRNimporter will append the first worksheet of that file to end of workbook wbDest
Dim strFile As String, sName As String
Dim ws As Worksheet
strFile = Dir(strPath & Application.PathSeparator & sNamePattern)
Do While strFile <> ""
    If strFile <> ActiveWorkbook.Name Then
            'Test to see if a worksheet with name similar to strFile already exists in wbDest. If not, then import it. _
                Without this test, duplicate copies of each worksheet were put in wbDest, and target workbooks were not closed
        sName = Left(strFile, InStrRev(strFile, ".") - 1)
        Set ws = Nothing
        On Error Resume Next
        Set ws = wbDest.Worksheets(sName)
        On Error GoTo 0
        If ws Is Nothing Then
            PRNImporter wbDest, strPath & Application.PathSeparator & strFile
            'Kill strPath & Application.PathSeparator & strFile
        End If
    End If
    strFile = Dir
Loop
End Sub
                                          
Sub PRNImporter(wbDest As Workbook, flPathName As String)
'Appends first worksheet in workbook at flPathName to workbook wbDest as last worksheet _
    Names that worksheet after original file name (less file extension)
Dim f As String
Dim i As Long, j As Long, k As Long

Set wbDest = ActiveWorkbook
i = wbDest.Worksheets.Count
j = Application.Workbooks.Count
Workbooks.OpenText flPathName, _
    StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
    ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=True, _
    Space:=True, Other:=True, DecimalSeparator:=".", ThousandsSeparator:=" ", TrailingMinusNumbers:=True
f = Workbooks(j + 1).Name
k = InStrRev(f, ".")
Workbooks(j + 1).Worksheets(1).Copy After:=wbDest.Worksheets(i)
wbDest.Worksheets(i + 1).Name = Left(f, k - 1)
Workbooks(j + 1).Close SaveChanges:=False
End Sub

Sub MakeSummarySheet(wbDest As Workbook)
Dim i As Long, j As Long, n As Long
Dim rg As Range
With wbDest
    n = .Worksheets.Count
    If n > 1 Then
        For i = 2 To n
            Set rg = .Worksheets(i).UsedRange
            Set rg = rg.Rows(rg.Rows.Count)
            '.Worksheets(1).Cells(i, 1).Resize(1, rg.Columns.Count).Value = rg.Value     'Copy data from last row to Summary worksheet column A
            .Worksheets(1).Cells(i, 1).Value = .Worksheets(i).Name                      'Copy worksheet name to Summary worksheet column A
            .Worksheets(1).Cells(i, 2).Resize(1, rg.Columns.Count).Value = rg.Value     'Copy data from last row to Summary worksheet column B
        Next
        .Worksheets(1).Name = "Summary"
    End If
End With
End Sub

Open in new window

0
dsmcl71Commented:
@ byundt
I've used your code to compile txt files into a single xls file, but would like to do some formatting (cell merge etc...) to each txt file as it is imported. At what point in your code should I insert the formatting code formatting?
The code below is what I already use to import and format a single file. I then have to re-save each file and then run your compile code to bring them all together.
Sub MergeText(Line, FirstCell, LastCell)
For i = (FirstCell + 1) To LastCell
Cells(Line, FirstCell).Value = Cells(Line, FirstCell).Value + _
Cells(Line, i).Value
Cells(Line, i).Value = ""
Next
End Sub

Sub ImportEggSortSupplierDataFile()
'
' ImportEggSortSupplierDataFile Macro
' Get file name
fileToOpen = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
If fileToOpen <> False Then
' Open file and convert data
Workbooks.OpenText Filename:=fileToOpen, _
Origin:=xlMSDOS, _
DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), _
Array(15, 1), _
Array(28, 1), _
Array(42, 1), _
Array(52, 1), _
Array(64, 1))
' Merge some of the text lines
For i = 2 To 4
Call MergeText(Line:=i, FirstCell:=1, LastCell:=6)
Next
For i = 7 To 18
Call MergeText(Line:=i, FirstCell:=1, LastCell:=2)
Next
' Set column width
For col = 1 To 6
Cells(1, col).ColumnWidth = 12
Next
End If
End Sub

Open in new window

0
byundtMechanical EngineerCommented:
dsmcl71,
You really should ask your own question (referencing this one) rather than tagging onto mldaigle1's question. The reason is that your request for help will only be seen by the people who were active in the original thread--and they may not have time to help when you need it.

I made a stab at integrating your code with the macro in this thread. I didn't test it, however, so be prepared for a little debugging. Since you might have other uses for your import routine and the line merge routine, I renamed them prior to making changes. I also added variable declarations to your original routines.

Sub TxtImporter()
Dim f As String, flPath As String
Dim i As Long, j As Long
Dim ws As Worksheet
Dim wb As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
flPath = ThisWorkbook.Path & Application.PathSeparator
i = ThisWorkbook.Worksheets.Count
j = Application.Workbooks.Count
f = Dir(flPath & "*.txt")
Do Until f = ""
    Workbooks.OpenText flPath & f, _
        Origin:=xlMSDOS, _
        DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), _
        Array(15, 1), _
        Array(28, 1), _
        Array(42, 1), _
        Array(52, 1), _
        Array(64, 1))
    Set wb = Workbooks(j + 1)
    ImportEggSortSupplierDataFileBY wb
    wb.Worksheets(1).Copy After:=ThisWorkbook.Worksheets(i)
    ThisWorkbook.Worksheets(i + 1).Name = Left(f, Len(f) - 4)
    wb.Close SaveChanges:=False
    i = i + 1
    f = Dir
Loop
Application.DisplayAlerts = True
End Sub

Sub MergeTextBY(ws As Worksheet, Line As Long, FirstCell As Long, LastCell As Long)
Dim i As Long
With ws
    For i = (FirstCell + 1) To LastCell
        .Cells(Line, FirstCell).Value = .Cells(Line, FirstCell).Value + _
            .Cells(Line, i).Value
        .Cells(Line, i).Value = ""
    Next
End With
End Sub

Sub ImportEggSortSupplierDataFileBY(wb As Workbook)
' ImportEggSortSupplierDataFile Macro
Dim ws As Worksheet
Dim col As Long, i As Long

Set ws = wb.Worksheets(1)

' Merge some of the text lines
For i = 2 To 4
    Call MergeTextBY(ws, Line:=i, FirstCell:=1, LastCell:=6)
Next
For i = 7 To 18
    Call MergeTextBY(ws, Line:=i, FirstCell:=1, LastCell:=2)
Next

' Set column width
For col = 1 To 6
    ws.Columns(col).ColumnWidth = 12
Next
End Sub

Sub MergeText(Line, FirstCell, LastCell)
Dim i As Long
For i = (FirstCell + 1) To LastCell
    Cells(Line, FirstCell).Value = Cells(Line, FirstCell).Value + _
    Cells(Line, i).Value
    Cells(Line, i).Value = ""
Next
End Sub

Sub ImportEggSortSupplierDataFile()
Dim fileToOpen As Variant
Dim col As Long, i As Long
'
' ImportEggSortSupplierDataFile Macro
' Get file name
fileToOpen = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
If fileToOpen <> False Then
    ' Open file and convert data
    Workbooks.OpenText Filename:=fileToOpen, _
        Origin:=xlMSDOS, _
        DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), _
        Array(15, 1), _
        Array(28, 1), _
        Array(42, 1), _
        Array(52, 1), _
        Array(64, 1))
    ' Merge some of the text lines
    For i = 2 To 4
        Call MergeText(Line:=i, FirstCell:=1, LastCell:=6)
    Next
    For i = 7 To 18
        Call MergeText(Line:=i, FirstCell:=1, LastCell:=2)
    Next
    ' Set column width
    For col = 1 To 6
        Cells(1, col).ColumnWidth = 12
    Next
End If
End Sub

Open in new window

Brad
0
dsmcl71Commented:
Thanks Brad,

Fair enough regarding asking my own question, fully understand. Just thought it may be easier, having already searched this posting, and not having to explain it all from scratch.

The code looks to be working great as it is - I've done no tweeking at all. Thank you for the quick response.
0
byundtMechanical EngineerCommented:
dsmcl71,
I'm glad the modified code is working for you.

When I looked at the code that was doing the data manipulation, the fact that you had each Array parameter on a separate line suggested to me that you wouldn't feel too uncomfortable with tweaking the code to do the necessary. Otherwise, I'd have been even firmer with my suggestion to open a new question.

Hope you enjoy working with the people on Experts Exchange. We have a great group of Experts in the Excel TA.

Egg sorting??? Should I be thinking about tabulating delivery receipts from farmers with a gazillion hens?

Brad
0
dsmcl71Commented:
Well now, maybe I will post another question. The .txt files number anywhere from 3 to 17 a day, 6 days a week and initially I was wondering if there is a way to just pull specific info from these files and store in a table. There is some data not recorded in the .txt files, which I have to add manually. But if it's possible to do it a better way, I have over 3 years worth of .txt files to go through ... I can provide sample .txt files and the headings for the table in the new question; if you think it's possible?
0
byundtMechanical EngineerCommented:
If there is a pattern, then you can definitely drive your data import with macro(s). You'll need to provide sample data and a workbook showing expected results. You will also need to provide a good description of exactly how to add the data that needs to be added manually.

I definitely suggest starting a new question for this purpose. Include a link to this question for historical context.And be patient, because the answer may come from somebody on the opposite of the world from Gippsland.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.