VBA替代Application.GetOpenFileName实现指定文件夹下CSV文件自动选中

核心修改为替换原手动选择文件的逻辑，改用Dir函数自动扫描指定目录下所有CSV文件，全程无需用户交互即可完成导入：

Sub ImportMultipleCSV()
Dim myfiles As Collection
Dim i As Integer
Dim xSht  As Worksheet
Dim ReportsDate As String
Dim targetPath As String, tempFileName As String

' 初始化参数
Set myfiles = New Collection
targetPath = "Q:\TEST\Reports CSV\"
' 路径存在校验，避免运行报错
If Dir(targetPath, vbDirectory) = "" Then
    MsgBox "指定文件夹不存在，请检查路径配置"
    Exit Sub
End If

ThisWorkbook.Worksheets("Import Data").Range("A3:AV100").ClearContents
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With

' 遍历目标路径下所有CSV文件
tempFileName = Dir(targetPath & "*.csv")
Do While tempFileName <> ""
    myfiles.Add targetPath & tempFileName
    tempFileName = Dir
Loop

' 原有导入逻辑适配新的文件集合
If myfiles.Count > 0 Then
  For i = 1 To myfiles.Count
    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 "指定文件夹下未找到符合条件的CSV文件"
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
Set myfiles = Nothing
End Sub

关键修改说明 #

• 用Collection集合存储扫描到的CSV文件路径，相比数组更方便动态扩容，适配文件数量不确定的场景
• 新增路径存在校验逻辑，避免因路径不存在、磁盘未挂载导致的运行错误
• 遍历逻辑使用Dir函数自动匹配目标路径下所有后缀为.csv的文件，完全替代原有的手动选择交互
• 如需额外增加文件名筛选规则（比如仅导入包含指定日期的CSV），只需在Do While循环内增加判断即可，示例：仅导入文件名包含当日日期的文件：

  Do While tempFileName <> ""
      ' 新增筛选规则：文件名包含yyyy-mm-dd格式的当日日期
      If InStr(tempFileName, Format(Date, "yyyy-mm-dd")) > 0 Then
          myfiles.Add targetPath & tempFileName
      End If
      tempFileName = Dir
  Loop
  

内容的提问来源于stack exchange，提问作者RosaTor