Macro to Import Text files in Folder into Excel

[xlUser]

Hello, the macro below imports the contents of a text file to specific excel cell location (the last populated cell). This works fine for the one file specified in the code but I would like to adapt the code so to that it will work on all text files in a given folder.

Is there an easy way to loop through all text files in the folder and import? On the surface, it appears the only lines/parameters that need to change in code are references to the file name:

With ActiveSheet.QueryTables.Add(Connection:= "TEXT;c:\Files\Imports\Fjames2321.txt"
.Name = "Fjames2321"

I need to make this part of the code/file names dynamic so that the macro will import each suucessive text file at the last populated cell in column A all in one go instead of having to change the files name references manually each time.

I hope this straight foward to do.

Thanks,

Excel User


[vba]
Sub Import_Extracts()
Range("A50000").End(xlUp).Offset(1, 0).Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;c:\Files\Imports\Fjames2321.txt" _
, Destination:=Range("A50000").End(xlUp).Offset(1, 0))
.Name = "Fjames2321"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "~"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.EntireRow.Delete
End Sub
[/vba]

[Tommy]

Hi xlUser,

The below code should work for you.
[VBA]
Sub Import_Extracts(FileName As String)
Range("A50000").End(xlUp).Offset(1, 0).Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & FileName _
, Destination:=Range("A50000").End(xlUp).Offset(1, 0))
.Name = "Fjames2321"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "~"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.EntireRow.Delete
End Sub
Sub DoThis()
Import_Extracts "c:\Files\Imports\Fjames2321.txt"
Import_Extracts "c:\Files\Imports\Fjames2322.txt"
Import_Extracts "c:\Files\Imports\Fjames2323.txt"
Import_Extracts "c:\Files\Imports\Fjames2324.txt"
Import_Extracts "c:\Files\Imports\Fjames2325.txt"
End Sub
[/VBA]

[Tommy]

My bad I missed the filename later in the file. The revised posted code below will work much better.
[VBA]
Sub Import_Extracts(FileName As String)
'
Dim Tmp As String
Tmp = Replace(FileName, ".txt", "")
Tmp = Mid(Tmp, InStrRev(Tmp, "\") + 1)
'
Range("A50000").End(xlUp).Offset(1, 0).Select
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & FileName _
, Destination:=Range("A50000").End(xlUp).Offset(1, 0))
.Name = Tmp
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "~"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.EntireRow.Delete
End Sub
Sub DoThis()
Import_Extracts "c:\Files\Imports\Fjames2321.txt"
Import_Extracts "c:\Files\Imports\Fjames2322.txt"
Import_Extracts "c:\Files\Imports\Fjames2323.txt"
Import_Extracts "c:\Files\Imports\Fjames2324.txt"
Import_Extracts "c:\Files\Imports\Fjames2325.txt"
End Sub

[/VBA]

[xlUser]

Thanks for your efforts here Tommy,

This looks great. Is it possible to do this without specifying the text file names? This is because each week the names of the text files change, they are not static but the location of the files/folder remains the same.

Sorry I should have mentioned this in my post. Hope this is easy to accomodate in the existing code you put together.

Thanks,

Xluser

[mostafa90]

gr8 answer indeed

[Tommy]

Sorry I didn't get a response from the website that anyone had posted.
This will fix you up
[vba]Sub DoThis()
Dim TxtArr() As String, I As Long
'TxtArr = BrowseForFile("c:\Files\Imports\")
TxtArr = Split(OpenMultipleFiles, vbCrLf)
For I = LBound(TxtArr, 1) To UBound(TxtArr, 1)
Import_Extracts TxtArr(I)
Next
End Sub
Sub Import_Extracts(Filename As String)
'
Dim Tmp As String
Tmp = Replace(Filename, ".txt", "")
Tmp = Mid(Tmp, InStrRev(Tmp, "\") + 1)
'
Range("A50000").End(xlUp).Offset(1, 0).Select
With ActiveSheet.QueryTables.add(Connection:= _
"TEXT;" & Filename _
, Destination:=Range("A50000").End(xlUp).Offset(1, 0))
.Name = Tmp
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "~"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.EntireRow.Delete
End Sub


'code copied from here and modified to work
'http://www.tek-tips.com/faqs.cfm?fid=4114
Function OpenMultipleFiles() As String
Dim Filter As String, Title As String, msg As String
Dim I As Integer, FilterIndex As Integer
Dim Filename As Variant
' File filters
Filter = "Text Files (*.txt),*.txt"
' Set Dialog Caption
Title = "Select File(s) to Open"
' Select Start Drive & Path
ChDrive ("C")
'ChDir ("c:\Files\Imports")
ChDir ("C:\Documents and Settings\tommyk\My Documents")
With Application
' Set File Name Array to selected Files (allow multiple)
Filename = .GetOpenFileName(Filter, FilterIndex, Title, , True)
' Reset Start Drive/Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
' Exit on Cancel
If Not IsArray(Filename) Then
MsgBox "No file was selected."
Exit Function
End If
msg = Join(Filename, vbCrLf)
OpenMultipleFiles = msg
End Function

[/vba]

EDIT: I STILL CAN"T SPELL