Importing multiple text files from a folder and saving to individual Excel files

ian.cook

New Member
Joined
Sep 8, 2012
Messages
12
Hi everyone,
I have cobbled together an Excel macro which imports a text file from a folder, strips away blank spaces, text and other characters and then saves the imported text file to a new Excel file, using the name of the text file as the new Excel filename. I'd like to be able to loop this such that this process will continue for however many text files are within the source folder.
Help would be much appreciated.
Thanks,
Ian

VBA Code:
Sub ImportText()
Dim fName As String

Application.ScreenUpdating = False

' Select Text file dialog box
fName = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If fName = "False" Then Exit Sub
' Import Text file using Import Wizard
    With Worksheets("Sheet2").QueryTables.Add(Connection:="TEXT;" & fName, _
        Destination:=Worksheets("Sheet2").Range("$A$1"))
        .Name = "Mark Sheet"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(9, 21, 9, 7, 7, 8, 7, 9, 9, 6, 7, 8, 12)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
 ' Delete brackets and underline
    Sheets("Sheet2").Select
    Cells.Replace What:="(", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:=")", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="_________  ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
' Autofit columns
    Cells.Select
    Selection.Columns.AutoFit
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        Range("A1").Select
    End With
' Delete rows with blanks and text characters from row 15 to row 1000
    Range("A15:A1000").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
    Range("A15:A1000").Select
    Selection.SpecialCells(xlCellTypeConstants, 2).Select
    Selection.EntireRow.Delete
' Copy signature line from Sheet1
    Sheets("Sheet1").Select
    Range("A50:I53").Select
    Selection.Copy
    Range("A1").Select
    Sheets("Sheet2").Select
'Paste signature line at end of Sheet2 document
    Dim lastRow As String
    lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 6
       Range("A" & lastRow).Select
       Selection.PasteSpecial
       Range("A1").Select
' Delete data connections
    Call deleteConnections
' Save Sheet2 as Excel workbook with imported text filename
    Dim strFolder As String
    strFile = fName & ".xlsx"
    Application.DisplayAlerts = False
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=strFile, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    Application.ScreenUpdating = True
'Delete data in Sheet2
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
'Return to Sheet1
    Sheets("Sheet1").Select
    Range("A1").Select
      
    Application.ScreenUpdating = True
   
End Sub
Sub deleteConnections()
     
    For i = 1 To ActiveWorkbook.Connections.Count
    If ActiveWorkbook.Connections.Count = 0 Then Exit Sub
    ActiveWorkbook.Connections.Item(i).Delete
    i = i - 1
    Next i
     
End Sub
 

Some videos you may like

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.

ian.cook

New Member
Joined
Sep 8, 2012
Messages
12
I've set it up this way and removed some code to prevent two dialogue boxes from opening. Also, the Loop code expressly does not look for individual file through the dialogue box, while my code does. I've set up my Import code as a separate Sub, and used a "Call" statement in the main Loop sub:

VBA Code:
Sub File_Loop_Example()
    'Excel VBA code to loop through files in a folder with Excel VBA

    Dim MyFolder As String, MyFile As String

    'Opens a file dialog box for user to select a folder

    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
       .Show
       MyFolder = .SelectedItems(1)
       Err.Clear
    End With

    'stops screen updating, calculations, events, and statsu bar updates to help code run faster
    'you'll be opening and closing many files so this will prevent your screen from displaying that

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'This section will loop through and open each file in the folder you selected
    'and then close that file before opening the next file

    MyFile = Dir(MyFolder & "\", vbReadOnly)

    Do While MyFile <> ""
        DoEvents
        On Error GoTo 0
        Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
        
     ''''''''''''ENTER YOUR CODE HERE TO DO SOMETHING'''''''''
        Call ImportText
        
        MsgBox MyFile
0
        Workbooks(MyFile).Close SaveChanges:=False
        MyFile = Dir
    Loop

    'turns settings back on that you turned off before looping folders

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationManual

    End Sub

Sub ImportText()
Application.ScreenUpdating = False

' Import Text file using Import Wizard
    With Worksheets("Sheet2").QueryTables.Add(Connection:="TEXT;" & fName, _
        Destination:=Worksheets("Sheet2").Range("$A$1"))
        .Name = "Mark Sheet"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileFixedColumnWidths = Array(9, 21, 9, 7, 7, 8, 7, 9, 9, 6, 7, 8, 12)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
 ' Delete brackets and underline
    Sheets("Sheet2").Select
    Cells.Replace What:="(", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:=")", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:="_________  ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
' Autofit columns
    Cells.Select
    Selection.Columns.AutoFit
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        Range("A1").Select
    End With
' Delete rows with blanks and text characters from row 15 to row 1000
    Range("A15:A1000").Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    Selection.EntireRow.Delete
    Range("A15:A1000").Select
    Selection.SpecialCells(xlCellTypeConstants, 2).Select
    Selection.EntireRow.Delete
' Copy signature line from Sheet1
    Sheets("Sheet1").Select
    Range("A50:I53").Select
    Selection.Copy
    Range("A1").Select
    Sheets("Sheet2").Select
'Paste signature line at end of Sheet2 document
    Dim lastRow As String
    lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 6
       Range("A" & lastRow).Select
       Selection.PasteSpecial
       Range("A1").Select
' Delete data connections
    Call deleteConnections
' Save Sheet2 as Excel workbook with imported text filename
    Dim strFolder As String
    strFile = fName & ".xlsx"
    Application.DisplayAlerts = False
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=strFile, _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    Application.ScreenUpdating = True
'Delete data in Sheet2
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
'Return to Sheet1
    Sheets("Sheet1").Select
    Range("A1").Select
      
    Application.ScreenUpdating = True
   
End Sub
Sub deleteConnections()
     
    For i = 1 To ActiveWorkbook.Connections.Count
    If ActiveWorkbook.Connections.Count = 0 Then Exit Sub
    ActiveWorkbook.Connections.Item(i).Delete
    i = i - 1
    Next i
 End Sub

I'm a bit stumped with this line of code:
VBA Code:
With Worksheets("Sheet2").QueryTables.Add(Connection:="TEXT;" & fName, _
        Destination:=Worksheets("Sheet2").Range("$A$1"))
This imported the text file into Excel into defined columns. But it used "fName" as one of the parameters for the Connection - but fName was part of the code I had to delete to prevent two dialogue boxes from opening. How do I direct the Import function to the first file to import? Not sure what to put in place of fName.

Thanks
 

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
56,703
Office Version
  1. 365
Platform
  1. Windows
Not sure what to put in place of fName.
If you are going to do it that way, using two procedures, having one call the other, you can going to have to add a parameter to the second, and pass the file name parameter to it.
In the first block, I believe it is "MyFile" that you want to pass to your "ImportText" procedure, and use that in place of the "fname" variable.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,847
Messages
5,627,239
Members
416,232
Latest member
Ash1432

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top