Loop through folder and covert txt files to excel and save

L

LearnVBA83

Board Regular
Joined
Dec 1, 2016
Messages
113
Office Version
  1. 365
Platform
  1. Windows
Hi VBASuperUsers,

With the growing knowledge I have on VBA along with great help from the forum, I've completed the below coding that will open my text file in excel and format the way I need it. My next obstacle is getting this code to Loop through a folder with multiple txt files and convert them to excel and save them in that folder or another folder. Is this even possible? Ideally I would like to have the code changed so that I click a button and it asks me what folder to choose with the text files. I choose that folder and it loops through and coverts all of the txt files to excel and does my formatting code and saves them. Any help would be greatly appreciated!!! Thanks you all for the wonderful help in the past.

Code: 
Option Explicit
Sub ImportTextFile()
Dim fName As String


fName = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If fName = "False" Then Exit Sub


    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fName, _
        Destination:=Range("$A$1"))
            .Name = "sample"
            .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)
            .TextFileFixedColumnWidths = Array(14, 13, 13, 14, 17, 10, 26, 5, 8)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
    End With
    
'Add Lockbox to File
    With Range("K2:K" & Range("I" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=if(r[-1]c[-2]=""PAGE"",rc[-5],if(rc[-2]=""PAGE"","""",r[-1]c))"
        .Value = .Value
    End With
    
'Add Date to File
    With Range("L2:L" & Range("I" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=if(r[-1]c[-3]=""PAGE"",rc[-10],if(rc[-2]=""PAGE"","""",r[-1]c))"
        .Value = .Value
    End With
    
'Delete Blank Rows using column H


  On Error Resume Next


Columns("H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete


'check for filter, turn on if none exists
  If Not ActiveSheet.AutoFilterMode Then
    ActiveSheet.Range("A1").AutoFilter
  End If
ActiveSheet.Range("$A$1:$A$1000000").AutoFilter Field:=1, Criteria1:= _
        "=*CHK NB*", Operator:=xlAnd
        
ActiveSheet.Range("A2:M1000000").Select
Selection.SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.Range("A1").AutoFilter = False


On Error Resume Next


'Replace OX with nothing and : in the date with nothing


Columns("K").Replace What:="OX ", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
                            
Columns("L").Replace What:=": ", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False


ActiveSheet.Range("K1").Value = "Lock Box"
ActiveSheet.Range("L1").Value = "Deposit Date"
ActiveSheet.Range("G:G").NumberFormat = "0"
ActiveSheet.Cells.EntireColumn.AutoFit
       
End Sub
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
Sort by date Sort by votes
Something like
Code: 
Sub OpenFldr()

    Dim FldrPth As String
    Dim InitPth As String
    Dim fname As String
    Dim Fldr As Object
    
   [COLOR=#0000ff] InitPth = "C:\Users\Fluff\Documents\Excel files"[/COLOR]
    
    Set Fldr = Application.FileDialog(4)
    With Fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
       [COLOR=#0000ff] .InitialFileName = InitPth[/COLOR]
        If .Show <> -1 Then Exit Sub
        FldrPth = .SelectedItems(1)
    End With
    
    FldrPth = FldrPth & "\"
    fname = Dir(FldrPth & "*.csv")
    Do While Len(fname) > 0
        Workbooks.Open (FldrPth & fname)
        
        ' Your code here
        
        Workbooks(fname).SaveAs FldrPth & Left(fname, Len(fname) - 4), 51
        ActiveWorkbook.Close , False
        fname = Dir
    Loop

End Sub
If you don't want to start with an initial path for the folder search, simply remove the 2 lines in blue.
Put your code (less the dim statement & first 2 lines of code) where I've shown
 
Upvote 0
Hi Fluff,

Thanks for your help. So I deleted the 2 lines above that you had in blue. I pasted my code where you said and deleted my first two lines. I created a test folder on my desktop and put 10 of the .txt files in the folder. I ran the macro and it asked me which folder do I want to select. I selected the test folder on my desktop and nothing happened. Any ideas? I've pasted my code below. Thanks again for the great help!

Code: 
Option Explicit
Sub OpenFldr()


    Dim FldrPth As String
    Dim InitPth As String
    Dim fname As String
    Dim Fldr As Object
    
      Set Fldr = Application.FileDialog(4)
      With Fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        FldrPth = .SelectedItems(1)
    End With
    
    FldrPth = FldrPth & "\"
    fname = Dir(FldrPth & "*.csv")
    Do While Len(fname) > 0
        Workbooks.Open (FldrPth & fname)


    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fname, _
        Destination:=Range("$A$1"))
            .Name = "sample"
            .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)
            .TextFileFixedColumnWidths = Array(14, 13, 13, 14, 17, 10, 26, 5, 8)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
    End With
    
'Add Lockbox to File
    With Range("K2:K" & Range("I" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=if(r[-1]c[-2]=""PAGE"",rc[-5],if(rc[-2]=""PAGE"","""",r[-1]c))"
        .Value = .Value
    End With
    
'Add Date to File
    With Range("L2:L" & Range("I" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=if(r[-1]c[-3]=""PAGE"",rc[-10],if(rc[-2]=""PAGE"","""",r[-1]c))"
        .Value = .Value
    End With
    
'Delete Blank Rows using column H


  On Error Resume Next


Columns("H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete


'check for filter, turn on if none exists
  If Not ActiveSheet.AutoFilterMode Then
    ActiveSheet.Range("A1").AutoFilter
  End If
ActiveSheet.Range("$A$1:$A$1000000").AutoFilter Field:=1, Criteria1:= _
        "=*CHK NB*", Operator:=xlAnd
        
ActiveSheet.Range("A2:M1000000").Select
Selection.SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.Range("A1").AutoFilter = False


On Error Resume Next


'Replace OX with nothing and : in the date with nothing


Columns("K").Replace What:="OX ", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
                            
Columns("L").Replace What:=": ", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False


ActiveSheet.Range("K1").Value = "Lock Box"
ActiveSheet.Range("L1").Value = "Deposit Date"
ActiveSheet.Range("G:G").NumberFormat = "0"
ActiveSheet.Cells.EntireColumn.AutoFit


Workbooks(fname).SaveAs FldrPth & Left(fname, Len(fname) - 4), 51
        ActiveWorkbook.Close , False
        fname = Dir
    Loop
       
End Sub
 
Upvote 0
Apologies, I was testing with .csv files & forgot to change to .txt, use the following line
Code: 
fname = Dir(FldrPth & "*.txt")
 
Upvote 0
Hi Fluff,

I think we are almost there! I am now getting the debug error: Run-time error '1004': Excel cannot find the text file to refresh this external data range. Check to make sure the text file has not been moved or renamed, then try the refresh again. When I click debug it highlights the below code in red. Please let me know if you have a solution. Thanks so much!

Code: 
Option Explicit
Sub OpenFldr()


    Dim FldrPth As String
    Dim InitPth As String
    Dim fname As String
    Dim Fldr As Object
    
      Set Fldr = Application.FileDialog(4)
      With Fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        FldrPth = .SelectedItems(1)
    End With
    
    FldrPth = FldrPth & "\"
    fname = Dir(FldrPth & "*.txt")
    Do While Len(fname) > 0
        Workbooks.Open (FldrPth & fname)


    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fname, _
        Destination:=Range("$A$1"))
            .Name = "sample"
            .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)
            .TextFileFixedColumnWidths = Array(14, 13, 13, 14, 17, 10, 26, 5, 8)
            .TextFileTrailingMinusNumbers = True
[COLOR=#ff0000]            .Refresh BackgroundQuery:=False[/COLOR]
    End With
    
'Add Lockbox to File
    With Range("K2:K" & Range("I" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=if(r[-1]c[-2]=""PAGE"",rc[-5],if(rc[-2]=""PAGE"","""",r[-1]c))"
        .Value = .Value
    End With
    
'Add Date to File
    With Range("L2:L" & Range("I" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=if(r[-1]c[-3]=""PAGE"",rc[-10],if(rc[-2]=""PAGE"","""",r[-1]c))"
        .Value = .Value
    End With
    
'Delete Blank Rows using column H


  On Error Resume Next


Columns("H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete


'check for filter, turn on if none exists
  If Not ActiveSheet.AutoFilterMode Then
    ActiveSheet.Range("A1").AutoFilter
  End If
ActiveSheet.Range("$A$1:$A$1000000").AutoFilter Field:=1, Criteria1:= _
        "=*CHK NB*", Operator:=xlAnd
        
ActiveSheet.Range("A2:M1000000").Select
Selection.SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.Range("A1").AutoFilter = False


On Error Resume Next


'Replace OX with nothing and : in the date with nothing


Columns("K").Replace What:="OX ", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
                            
Columns("L").Replace What:=": ", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False


ActiveSheet.Range("K1").Value = "Lock Box"
ActiveSheet.Range("L1").Value = "Deposit Date"
ActiveSheet.Range("G:G").NumberFormat = "0"
ActiveSheet.Cells.EntireColumn.AutoFit


Workbooks(fname).SaveAs FldrPth & Left(fname, Len(fname) - 4), 51
        ActiveWorkbook.Close , False
        fname = Dir
    Loop
       
End Sub
 
Upvote 0
Apologies for the delay in replying, I must have missed the notification.

The suggestion I made was based on the description you gave in the op.
Having looked at the code you supplied, it does not seem to be opening any files. It's simply pulling the data into the active sheet on another file.
Could you please confirm, which you want?
 
Upvote 0
Hi Fluff,

Thanks for all of the help. I managed to get the below coding to do what needed to be done. Thanks again!


Code: 
Option Explicit
Sub ImportTextFile()
Dim fname As String
Dim FSO As New FileSystemObject
Dim fl As File, i As Long
Dim fldr As String, LastRow As Long
Dim fd As Folder, ws As Worksheet
Dim wb As Workbook


'Set wb = Workbooks.Add
'Set ws = wb.ActiveSheet
    'On Error GoTo L1
    Application.FileDialog(msoFileDialogFolderPicker).Show
    
    fldr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    Set fd = FSO.GetFolder(fldr)
    For Each fl In fd.Files
    Set wb = Workbooks.Add
    Set ws = wb.ActiveSheet
    'fname = Application.GetOpenFilename("Text Files (*.txt), *.txt")
    fname = fl
    If fname = "False" Then Exit Sub
'    With ActiveSheet
'        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'    End With
'    With ws
'        i = .Cells(.Rows.Count, 1).End(xlUp).Row
'        ActiveSheet.Copy ws.Range("A" & i)
'    End With
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fname, _
        Destination:=Range("$A$1"))
            .Name = "sample"
            .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)
            .TextFileFixedColumnWidths = Array(14, 13, 13, 14, 17, 10, 26, 5, 8)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
    End With
    
'Add Lockbox to File
    With Range("K2:K" & Range("I" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=if(r[-1]c[-2]=""PAGE"",rc[-5],if(rc[-2]=""PAGE"","""",r[-1]c))"
        .Value = .Value
    End With
    
'Add Date to File
    With Range("L2:L" & Range("I" & Rows.Count).End(xlUp).Row)
        .FormulaR1C1 = "=if(r[-1]c[-3]=""PAGE"",rc[-10],if(rc[-2]=""PAGE"","""",r[-1]c))"
        .Value = .Value
    End With
    
'Delete Blank Rows using column H


  On Error Resume Next


Columns("H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete


'check for filter, turn on if none exists
  If Not ActiveSheet.AutoFilterMode Then
    ActiveSheet.Range("A1").AutoFilter
  End If
ActiveSheet.Range("$A$1:$A$1000000").AutoFilter Field:=1, Criteria1:= _
        "=*CHK NB*", Operator:=xlAnd
        
ActiveSheet.Range("A2:M1000000").Select
Selection.SpecialCells(xlCellTypeVisible).EntireRow.Delete
ActiveSheet.Range("A1").AutoFilter = False


On Error Resume Next


'Replace OX with nothing and : in the date with nothing


Columns("K").Replace What:="OX ", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False
                            
Columns("L").Replace What:=": ", _
                            Replacement:="", _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            MatchCase:=False, _
                            SearchFormat:=False, _
                            ReplaceFormat:=False


ActiveSheet.Range("K1").Value = "Lock Box"
ActiveSheet.Range("L1").Value = "Deposit Date"
ActiveSheet.Range("G:G").NumberFormat = "0"
ActiveSheet.Cells.EntireColumn.AutoFit
'CreateNewBook ws
ActiveWorkbook.SaveAs (fl & ".xlsx")
ActiveWorkbook.Close
Next
       
End Sub


Function CreateNewBook(ws As Worksheet)
Dim i As Long
    Set ws = ActiveWorkbook.Worksheets("Sheet2")
    With ws
        i = .Cells(.Rows.Count, 1).End(xlUp).Row
        ActiveSheet.Copy ws.Range("A" & i)
    End With
End Function


'Function FolderLookup()
'
'Dim FSO As New FileSystemObject
'Dim fl As File, i As Long
'Dim fldr As String
'Dim fd As Folder, ws As Worksheet
'
'    On Error GoTo L1
'    Application.FileDialog(msoFileDialogFolderPicker).Show
'
'    fldr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
'    If fldr = "" Then Exit Function
'    'Set ws = ThisWorkbook.Worksheets("Data")
'    ClearData ws
'    sTime = Now()
'    With ws
'        Set fd = FSO.GetFolder(fldr)
'        CheckFile fd, ws
'        For Each fd In fd.SubFolders
'            CheckFile fd, ws
'            CheckFolder fd, ws
'            DoEvents
'        Next
'End Function
 
Upvote 0
Glad you got it sorted & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Add a code or number at the end of the file name using VBA (Looped)
Replies
3
Views
122
HighAndWilder
H
S
  • Solved
Change export from .txt to workbook
Replies
1
Views
271
HighAndWilder
H
S
  • Question Question
vba logic to open up several files within a folder and perform 2-3 steps
Replies
1
Views
398
ranman256
ranman256
F
  • Solved
How to make loop stop when the cell is empty? (VBA)
Replies
3
Views
298
kvsrinivasamurthy
K
B
  • Question Question
Copy and paste from one worksheet into a new workbook and save to a particular directory
Replies
3
Views
730
Joe4
Joe4

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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