I created a pretty good working vba code for importing a csv file from the windows file explorer. However, when I close the explorer before I open a file, a 1004 error dialog pops up. It says the text file to refresh the external range can't be found. The line line at the bottom should be the cause:
.Refresh BackgroundQuery:=False
Does anyone have an idea how to get rid of this error?
Dim ClickCount As Integer
Sub CommandButton1_Click()
Dim sht As Worksheet
Dim LastRow As Long
Dim begin As String
Dim myInput As Long
ClickCount = ClickCount + 1
If ClickCount > 1 Then GoTo Line1 Else GoTo Line2
Line1:
myInput = MsgBox("Gebruikers zijn reeds geimporteerd. Records worden mogelijk dubbel opgeslagen. Wilt u toch doorgaan met importeren?", vbCritical + vbYesNo, "Import error")
If myInput = vbYes Then
GoTo Line2
Else
Exit Sub
Line2:
Set sht = ActiveSheet
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
begin = "$A" & "$" & LastRow + 1
Dim fileName
fileName = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv),*.csv")
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & fileName, _
Destination:=range(begin))
.Name = "User import 1.0"
.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 = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End If
End Sub
Dim fileName
fileName = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv),*.csv")
If fileName = False then Exit Sub
Related
I am able to import multiple sheets. Each imported file have 2 columns. I want the first file to be placed on Column A and Column B and the second imported file to be placed on Column C and column D on the same sheet.
The following below is my code to import multiple sheets.
Sub ImportFiles()
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Dim path As String
Dim filename As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim vrtSelectedItem As Variant
With fd
.AllowMultiSelect = True
'Set the initial path to the C:\ drive.
.InitialFileName = ActiveWorkbook.path
'Add a filter that includes the list.
.Filters.Clear
.Filters.Add "Text Files", "*.txt", 1
'The user pressed the button.
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
path = Left(vrtSelectedItem, InStrRev(vrtSelectedItem, "\"))
filename = Right(vrtSelectedItem, Len(vrtSelectedItem) - InStrRev(vrtSelectedItem, "\"))
Call Importfile(path, filename)
Next vrtSelectedItem
Else
End If
End With
Set fd = Nothing
End Sub
Sub Importfile(path As String, filename As String)
'Sheets.Add(After:=Sheets("Sheet1")).Name = "RawData"
'ActiveSheet.Name = filename
On Error Resume Next
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & path & filename, Destination:=Range("$A$1"))
.Name = filename
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileOtherDelimiter = vbTab
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = " "
.Refresh BackgroundQuery:=False
End With
End Sub
I did try to place a for loop after "If .Show =-1 Then," such as
Dim FileNames As String
Dim WSNew As Worksheet
For Each filename in FileNames
Set WSNew = ActiveWorkbook.Sheets.Add
Next filename
but it shows an error such that it cant compile it.
Replace your existing procedure with this one:-
Sub Importfile(path As String, filename As String)
Dim Target As Range
Dim C As Long
'Sheets.Add(After:=Sheets("Sheet1")).Name = "RawData"
'ActiveSheet.Name = filename
On Error Resume Next
With ActiveSheet
C = .Cells(1, .Columns.Count).End(xlToLeft).Column
If C > 1 Then C = C + 1
Set Target = .Cells(1, C)
With .QueryTables.Add(Connection:="TEXT;" & path & filename, _
Destination:=Target)
.Name = filename
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = False
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = xlWindows
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileOtherDelimiter = vbTab
.TextFileDecimalSeparator = "."
.TextFileThousandsSeparator = " "
.Refresh BackgroundQuery:=False
End With
End With
End Sub
Everything remains same as before but the newly imported file will be written to the next free cell in row 1.
Updated.
I have the following code:
Sub ImportTextFile()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Val(Application.Version) > 15 Then
If ActiveWorkbook.AutoSaveOn Then ActiveWorkbook.AutoSaveOn = False
End If
Dim Ret
Dim newWorksheet As Worksheet
Set newWorksheet = Sheets.Add(After:=Sheets("Konvertering"))
Ret = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If Ret <> False Then
With newWorksheet.QueryTables.Add(Connection:= _
"TEXT;" & Ret, Destination:=newWorksheet.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 = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
newWorksheet.Name = Mid$(Ret, InStrRev(Ret, "\") + 1)
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
It imports a textfile to a new sheet in Excel. How can I update the code so that the new sheet gets the same name as the textfile that was imported?
First, when adding the new worksheet, assign it to an object variable for reference later...
Dim newWorksheet As Worksheet
Set newWorksheet = Sheets.Add(After:=Sheets("Konvertering"))
Then, you can refer to the new worksheet for your query and name your new worksheet as follows...
If Ret <> False Then
With newWorksheet.QueryTables.Add(Connection:= _
"TEXT;" & Ret, Destination:=newWorksheet.Range("$A$1"))
'etc
'
'
End With
newWorksheet.Name = Mid$(Ret, InStrRev(Ret, "\") + 1)
End If
Double InstrRev
You were just another InstrRev away from the solution.
Let's say the path is C:\Test\Input.txt.
After applying InstrRev with \ to Ret ...
x = Mid$(Ret, InStrRev(Ret, "\") + 1)
you got this: Input.txt.
Now you just have to apply InstrRev with . to x ...
FileName = Mid$(x, 1, InStrRev(x, ".") - 1)
to get this: Input.
And now you have to get rid off x i.e. replace x in the second expression with the right side of the first expression to get this:
FileName = Mid$(Mid$(Ret, InStrRev(Ret, "\") + 1), 1, _
InStrRev(Mid$(Ret, InStrRev(Ret, "\") + 1), ".") - 1)
Hence the solution:
Replace this ...
newWorksheet.Name = Mid$(Ret, InStrRev(Ret, "\") + 1)
...with
newWorksheet.Name = Mid$(Mid$(Ret, InStrRev(Ret, "\") + 1), 1, _
InStrRev(Mid$(Ret, InStrRev(Ret, "\") + 1), ".") - 1)
...and you're done.
EDIT:
Links
Workbook.SaveAs
XlFileFormat
The Code
Option Explicit
Sub ImportTextFile()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' The following line is usually written immediately after the previous
' two lines.
On Error GoTo ProgramError
If Val(Application.Version) > 15 Then
If ActiveWorkbook.AutoSaveOn Then ActiveWorkbook.AutoSaveOn = False
End If
Dim Ret As Variant
Dim newWorksheet As Worksheet
Dim ws As Worksheet ' For Each Control Variable
Dim finishSuccess As Boolean
Dim fileName As String
Set newWorksheet = Sheets.Add(After:=Sheets("Konvertering"))
Ret = Application.GetOpenFilename("Text Files (*.txt), *.txt")
' Define fileName
fileName = Mid$(Mid$(Ret, InStrRev(Ret, "\") + 1), 1, _
InStrRev(Mid$(Ret, InStrRev(Ret, "\") + 1), ".") - 1)
' Check if fileName exceeds 31 character limit:
If Len(fileName) > 31 Then GoTo FileNameTooLong
' Check if worksheet name exists.
For Each ws In ThisWorkbook.Worksheets
If ws.Name = fileName Then GoTo WorksheetNameTaken
Next ws
' Import Text File
If Ret = False Then GoTo SafeExit
With newWorksheet.QueryTables.Add(Connection:= _
"TEXT;" & Ret, Destination:=newWorksheet.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 = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
newWorksheet.Name = fileName
' Stop Excel complaining about losing the code.
Application.DisplayAlerts = False
' Assuming you want to save the file as .xlsx (without code).
ThisWorkbook.SaveAs fileName, xlOpenXMLWorkbook
' If you want to save as .xlsm (with code) then use
' 'xlOpenXMLWorkbookMacroEnabled' and remove the lines
' containing 'Application.DisplayAlerts ...'.
Application.DisplayAlerts = True
' If I'm mmissing the point, just outcomment the previous Application
' block and uncomment the following line and make changes appropriately.
' Thisworkbook.SaveAs fileName, xlOpenXMLWorkbookMacroEnabled
finishSuccess = True
SafeExit:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
If finishSuccess Then
MsgBox "Finished successfully.", vbInformation, "Success"
' Close workbook without saving changes (False) ensuring that it
' always stays the same. Remove 'False' if I'm missing the point.
ThisWorkbook.Close False
End If
Exit Sub
WorksheetNameTaken:
MsgBox "There is already a worksheet named '" & fileName & "'.", _
vbInformation, "Custom Error Message"
GoTo SafeExit ' or change appropriately.
FileNameTooLong:
MsgBox "The file name '" & fileName & "' exceeds the 31 character limit.", _
vbInformation, "Custom Error Message"
GoTo SafeExit ' or change appropriately.
ProgramError:
' Handle Error (You can do better. A hint: 'vbYesNo'.)
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Custom Error Message"
On Error GoTo 0
GoTo SafeExit ' or change appropriately.
End Sub
I'm used this great resource Import CSV files into Excel, and it was working great last week, but this week i can't get it to work.
What changed?
Sub ImportAllCSV()
Dim FName As Variant, R As Long
R = 1
FName = Dir("*.csv")
Do While FName <> ""
ImportCsvFile FName, ActiveSheet.Cells(R, 1)
R = ActiveSheet.UsedRange.Rows.Count + 1
FName = Dir
Loop
Call KopieraUnikaRaderBlad
Call RaderaLine
Call SammanStall
Call SidforNummer
End Sub
' Sub för att importera csv fil info till blad med namn från filnamnet
Sub ImportCsvFile(FileName As Variant, Position As Range)
Dim newString As String
Dim char As Variant
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & FileName _
, Destination:=Range("$A$1"))
.Name = "A00-40---1-D02------ Klar_allt"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.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)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
' det som är in kopierat några kolumner tas bort
Columns("C:I").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
newString = Right(FileName, 25)
'fixar till bladnamnet
For Each char In Split(SpecialCharacters, ",")
newString = Replace(newString, char, "")
Next
ActiveSheet.Name = Left(newString, Len(newString) - 3)
End Sub
This must be Excel "default" location that changed, or you moved the csv files.
You macro Sub ImportAllCSV() will only work if you have files in the current directory.
To be sure, one solution is to use the complete path, e.g.
fName = "C:\local\my_existing_file.csv"
Otherwise, with your formula, FName = Dir("*.csv") calls to the directory Excel considers as "default". This is the directory you have when going to File > Open...
If you want to be sure of current path, then try Re-Initializing "ThisWorkbook.Path", like with the below:
Set CurrWB = Workbooks("the_current_workbook_you_want.xlsm")
directory = currwb.path
FName = Dir(directory & "\*.csv")
This is the answer
Sub ImportAllCSV()
Dim FName As Variant, R As Long
Application.ScreenUpdating = False
R = 1
Set CurrWB = Workbooks("Bok1.xlsm")
directory = CurrWB.Path & "\"
FName = Dir(directory & "*.csv")
Do While FName <> ""
ImportCsvFile FName, ActiveSheet.Cells(R, 1), directory
R = ActiveSheet.UsedRange.Rows.Count + 1
FName = Dir
Loop
Call KopieraUnikaRaderBlad
Call RaderaLine
Call SammanStall
Call SidforNummer
Call KollaFlyttaData
'Call RäknaData
Application.ScreenUpdating = True
End Sub
Sub ImportCsvFile(FileName As Variant, Position As Range, directory As Variant)
Dim newString As String
Dim char As Variant
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & directory & FileName _
, Destination:=Range("$A$1"))
.Name = "A00-40---1-D02------ Klar_allt" 'vet inte vad den här linjen gör verkar som inget
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.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)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
.WorkbookConnection.Delete
End With
' det som är in kopierat några kolumner tas bort
Columns("C:I").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
newString = Right(FileName, 25)
'fixar till bladnamnet
For Each char In Split(SpecialCharacters, ",")
newString = Replace(newString, char, "")
Next
ActiveSheet.Name = Left(newString, Len(newString) - 3)
End Sub
When importing multiple txt files via VBA into Excel I run into the an out of memory warning related to .Refresh BackgroundQuery:=False. At exactly 723 properly imported text files the error pops up.
This is the VBA code I use:
Sub Sample()
Dim myfiles
Dim i As Integer
myfiles = Application.GetOpenFilename(filefilter:="Text files (*.txt), *.txt", MultiSelect:=True)
If Not IsEmpty(myfiles) Then
For i = LBound(myfiles) To UBound(myfiles)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myfiles(i), Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1, 0))
.Name = "Sample"
.FieldNames = False
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next i
Else
MsgBox "No File Selected"
End If
End Sub
How can I solve this?
I believe that this has to do with the cache size, page size and records per page. If you try the following code
objRecordset.Open "SELECT * FROM " & CSV_FILE, objConnection, adOpenStatic, adLockOptimistic, adCmdText
If Not objRecordset.EOF Then
intpagecount = objRecordset.PageCount
MsgBox intpagecount
MsgBox objRecordset.PageSize
Debug.Print objRecordset.CacheSize
end if
on a large CSV file, you'll find that VBA always shows a Memory Full error at the end of each page. In this case, there are 10 records per page, and 50585 pages. Sure enough, I get a memory full at each page 10*50585 = 505850 records.
You may have lots of connections in the workbook as you keep adding them but not deleting them afterwards.
Try this but run Sub CleanUpQT() first as a one off. Also, some of your ranges are not fully qualified which will cause problems if you change sheets while the code runs. Set whichever sheet you want this to operate on using Set ws = Sheet1 - where Sheet1 is the codename or similar.
Option Explicit
Sub Sample()
Dim myfiles As Variant
Dim i As Integer
Dim temp_qt As QueryTable
Dim ws As Worksheet
myfiles = Application.GetOpenFilename(filefilter:="Text files (*.txt), *.txt", MultiSelect:=True)
If Not IsEmpty(myfiles) Then
Set ws = Sheet1
For i = LBound(myfiles) To UBound(myfiles)
Set temp_qt = ws.QueryTables.Add(Connection:= _
"TEXT;" & myfiles(i), Destination:=ws.Range("A" & ws.Rows.Count).End(xlUp).Offset(1, 0))
With temp_qt
.Name = "Sample"
.FieldNames = False
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next i
Set temp_qt = Nothing
CleanUpQT
Else
MsgBox "No File Selected"
End If
End Sub
Sub CleanUpQT()
Dim connCount As Long
Dim i As Long
connCount = ThisWorkbook.Connections.Count
For i = 1 To connCount
ThisWorkbook.Connections.Item(i).Delete
Next i
End Sub
I am having a problem with some VBA code. I'm running Excel 2010 on Windows 7 Enterprise.
I'm trying to read in several tab-delimited text files from a folder and put them onto separate sheets in one Excel workbook. To do this, I'm using a Query Table. In debugging, I have a problem with .Refresh BackgroundQuery:=False. When it reaches this line, it throws a 1004 run-time error, stating that Excel cannot find the text file to refresh this external data range. I don't know why this is occurring. I know that the Query Table isn't created until it reads this line, which makes debugging difficult. Here is the code. Any help would be much appreciated. Thanks in advance!
Sub LoadPipeDelimitedFiles()
Dim idx As Integer
Dim fname As String
idx = 0
fname = Dir("C:\files\*.txt")
While (Len(fname) > 0)
idx = idx + 1
Sheets("Sheet" & idx).Select
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fname, Destination:=Range("A1"))
.Name = "a" & idx
.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 = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
fname = Dir
End With
Wend
End Sub
Here is the correction:
Sub LoadPipeDelimitedFiles()
Dim idx As Integer
Dim fpath As String
Dim fname As String
Dim f_dummy As String
idx = 0
fpath = "C:\files\"
f_dummy = fpath & "*.txt"
fname = Dir(f_dummy)
While (Len(fname) > 0)
idx = idx + 1
Sheets("Sheet" & idx).Select
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" _
& fpath & fname, Destination:=Range("A1"))
.Name = "a" & idx
.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 = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
fname = Dir
End With
Wend
End Sub
Change the line With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fname, Destination:=Range("A1"))
to
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & "C:\files\" & fname, Destination:=Range("A1"))
You fname just has the name of the file and not the full path
Also avoid using .Select and fully qualify your Objects.
INTERESTING READ
Your code can be written as
Sub LoadPipeDelimitedFiles()
Dim idx As Integer
Dim fname As String, FullName As String
Dim ws As Worksheet
idx = 0
fname = Dir("C:\*.txt")
While (Len(fname) > 0)
FullName = "C:\" & fname
idx = idx + 1
Set ws = ThisWorkbook.Sheets("Sheet" & idx)
With ws.QueryTables.Add(Connection:="TEXT;" & _
FullName, Destination:=ws.Range("A1"))
'
'~~> Rest of the code
'
fname = Dir
End With
Wend
End Sub