在VBA中导入txt文件时添加文件名

我刚刚写了一个程序，导入.txt文件到Excel。

我尝试将文件名（custName）导入到工作表的第一行，并在下面开始.txt。 我的文件名被导入滞后于相关联的.txt文件两列，并且第一次导入的文件名总是丢失。

我是否错过了某种偏移或者是第一个for循环运行的东西？

Function import(shtraw) With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Please select a folder" .Show .AllowMultiSelect = False If .SelectedItems.Count = 0 Then MsgBox "You did not select a folder" Exit Function End If MyFolder = .SelectedItems(1) End With Set fileSystemObject = CreateObject("Scripting.FileSystemObject") Set folderObj = fileSystemObject.getfolder(MyFolder) shtraw.Select For Each fileObj In folderObj.Files 'loop through files If (fileSystemObject.GetExtensionName(fileObj.Path) = "txt") Then If Not fileObj.Attributes And 2 Then arrFileName = Split(fileObj.Path, "\") Path = "TEXT:" & fileObj.Path filename = arrFileName(UBound(arrFileName)) 'Get the filename without the.mtmd CustName = Mid(filename, 1, InStr(filename, ".") - 1) shtraw.range("$A$1").value = CustName With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fileObj.Path, Destination:=range("$A$2")) .name = filename .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 .TextFileColumnDataTypes = Array(1, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With End If 'end if hidden if statement End If 'end of txt Next fileObj 'close loop range("$A$1:$B$1").Delete shift:=xlToLeft End Function 

Answer 1

我试图使用计数器来抵消你的文件名从A1和查询从A2 ，它工作正常。

请注意，您可以在DIR使用通配符（请参阅使用VBA循环访问文件夹中的文件？ ），而不是使用FileScriptingObject

 Function import(shtraw) Dim lngCnt As Long With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Please select a folder" .Show .AllowMultiSelect = False If .SelectedItems.Count = 0 Then MsgBox "You did not select a folder" Exit Function End If MyFolder = .SelectedItems(1) End With Set fileSystemObject = CreateObject("Scripting.FileSystemObject") Set folderObj = fileSystemObject.getfolder(MyFolder) shtraw.Select For Each fileObj In folderObj.Files 'loop through files If (fileSystemObject.GetExtensionName(fileObj.Path) = "txt") Then If Not fileObj.Attributes And 2 Then arrFileName = Split(fileObj.Path, "\") Path = "TEXT:" & fileObj.Path Filename = arrFileName(UBound(arrFileName)) 'Get the filename without the.mtmd CustName = Mid(Filename, 1, InStr(Filename, ".") - 1) shtraw.Range("$A$1").Offset(0, lngCnt).Value = CustName With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fileObj.Path, Destination:=Range("$A$2").Offset(0, lngCnt)) .Name = Filename .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 .TextFileColumnDataTypes = Array(1, 1, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With lngCnt = lngCnt + 1 End If 'end if hidden if statement End If 'end of txt Next fileObj 'close loop End Function 

Answer 2

那么，在最后你删除了单元格A1到B1，而你之前写入文件名到A1。 这应该导致两个文件名丢失，第三个单元格A1结束。