导入CSV文件到Excel / Dir函数不起作用

我使用这个伟大的资源导入CSV文件到Excel ，上周工作很好，但是这个星期我不能得到它的工作。

什么改变了？

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 

Answer 1

这必须是已更改的Excel“默认”位置，或者您移动了csv文件。

您的macrosSub ImportAllCSV()将只在当前目录中有文件时才起作用。

可以肯定的是，一个解决scheme是使用完整的path，例如

 fName = "C:\local\my_existing_file.csv" 

否则，用你的公式， FName = Dir("*.csv")调用Excel认为是默认的目录。 这是您进入File> Open …时的目录

如果您想确定当前path，请尝试重新初始化“ThisWorkbook.Path” ，如下所示：

 Set CurrWB = Workbooks("the_current_workbook_you_want.xlsm") directory = currwb.path FName = Dir(directory & "\*.csv") 

Answer 2

这是答案

 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