自动选择文件夹中的所有文件与过滤器(替代不使用Application.GetOpenFileName)

Question

我有一个代码，通过应用程序选择多个'.csv'文件。GetOpenFilename用于以后导入这些文件，但我希望在特定文件夹中自动选择所有文件，而不需要用户手动选择它们。

这是我有兴趣改进的部分。在完整代码的下面，以防有其他需要更改的地方。

ChDrive "Q"
ChDir "Q:TESTReports CSV"
myfiles = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)

完整代码:

Sub ImportMultipleCSV()
Dim myfiles
Dim i As Integer
Dim xSht  As Worksheet
Dim ReportsDate As String
ThisWorkbook.Worksheets("Import Data").Range("A3:AV100").ClearContents
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
ChDrive "Q"
ChDir "Q:TESTReports CSV"
myfiles = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
'Import multiple csv in semicolon delimitation
If IsArray(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
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next i
Else
MsgBox "No File Selected"
End If
Dim xConnect As Object
For Each xConnect In ActiveWorkbook.Connections
If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete
Next xConnect
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

Answer 1

您可以使用Dir函数从文件夹中自动检索所有CSV文件。因此，您的代码可以重写如下…

Sub ImportMultipleCSV()
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With

Dim destWS As Worksheet
Set destWS = ThisWorkbook.Worksheets("Import Data")
destWS.Range("A3:AV100").ClearContents

Dim fileCount As Long
fileCount = 0

Dim myPath As String
myPath = "C:UsersDomenicDesktop" 'change the path accordingly
If Right(myPath, 1) <> "" Then
myPath = myPath & ""
End If

'get the first CSV file from the folder
Dim myFile As String
myFile = Dir(myPath & "*.csv", vbNormal)

'loop through each CSV in the folder
While Len(myFile) > 0
'Import multiple csv in semicolon delimitation
With destWS.QueryTables.Add(Connection:= _
"TEXT;" & myPath & myFile, Destination:=destWS.Range("A" & destWS.Rows.Count).End(xlUp).Offset(1, 0))
.Name = myFile
.FieldNames = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = True
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 2
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileCommaDelimiter = True
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
fileCount = fileCount + 1
myFile = Dir 'get the next CSV from the folder
Wend

If fileCount > 0 Then
Dim xConnect As Object
For Each xConnect In ActiveWorkbook.Connections
If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete
Next xConnect
End If

With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With

MsgBox "Number of files processed: " & fileCount
End Sub

请注意，如果您的文件实际上是用分号而不是逗号分隔的，则需要通过替换…来修改上面的代码

.TextFileCommaDelimiter = True

.TextFileSemicolonDelimiter = True