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

I

ian.cook

New Member
Joined
Sep 8, 2012
Messages
16
Office Version
  1. 2007
Platform
  1. Windows
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
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Sort by date Sort by votes
Joe4 said:
Take a look here: Loop Through Files In A Folder With Excel VBA | Excelerator.Solutions
Click to expand...
Joe4 said:
Take a look here: Loop Through Files In A Folder With Excel VBA | Excelerator.Solutions
Click to expand...
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
 
Upvote 0
ian.cook said:
Not sure what to put in place of fName.
Click to expand...
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Question Question
US/European Date Format Updates Not Working on Macro Run
Replies
0
Views
117
vancher19
V
C
  • Solved
VBA Too Slow
Replies
1
Views
312
Cubist
Cubist
M
  • Question Question
Saveas newwb, close new wb, delete old wb
Replies
8
Views
536
eiloken
E
N
  • Question Question
Not understanding loop in vba
Replies
7
Views
316
jolivanes
jolivanes
L
  • Question Question
How to loop to find and replace with the specific cells
Replies
2
Views
333
Linda Lo
L

Forum statistics

Threads
1,224,574
Messages
6,179,626
Members
452,933
Latest member
patv

Share this page

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
Back
Top