用過濾器自動選擇檔案夾中的所有檔案（不使用Application.GetOpenFileName的替代方案）。

我有一段代碼，通過Application.GetOpenFilename選擇多個'.csv'檔案，以便隨后匯入這些檔案，但我希望能自動選擇特定檔案夾中的所有檔案，而不需要用戶手動選擇它們。

這是我有興趣改進的部分。下面是完整的代碼，以備其他需要改變的地方。

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 作業表
Dim ReportsDate As String
ThisWorkbook.Worksheets("匯入資料").Range("A3:AV100").ClearContents
With Application
.DisplayAlerts = False[/span]。
.EnableEvents = False[/span
.ScreenUpdating = False[/span
結束 與
ChDrive "Q"/span>
ChDir "Q:TESTReports CSV"/span>
myfiles = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
'匯入多個csv的分號定界。
If IsArray(myfiles) Then
  For i = LBound(myfiles) To UBound(myfiles)
    With ActiveSheet.QueryTables.Add(Connection:= _)
      "TEXT;" & myfiles(i), Destination:=Range("A"/span> & Rows. Count).End(xlUp).Offset(1, 0)
    .Name = "Sample"False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False[/span
    .RefreshStyle = xlInsertDeleteCells
    
    .TextFilePromptOnRefresh = False
    .TextFilePlatform = 437[/span
    .TextFileStartRow = 2
    .TextFileParseType = xlDelimited
    .TextFileTextQualifier = xlTextQualifierDoubleQuote
    .TextFileConsecutiveDelimiter = True
    .TextFileSemicolonDelimiter = TrueTrue
    .Refresh BackgroundQuery:=False
  結束 有
Next i
Else[/span
MsgBox "沒有選擇的檔案"End If
Dim xConnectAs Object
   For Each xConnect In ActiveWorkbook.Connections
      If xConnect.Name <> "ThisWorkbookDataModel"/span> Then xConnect.Delete
Next xConnect
With Application
.DisplayAlerts = True
.EnableEvents = True[/span
.ScreenUpdating = True[/span
結束 與
結束 Sub

uj5u.com熱心網友回復：

你可以使用Dir函式來自動檢索你檔案夾中的所有CSV檔案。 相應地，你的代碼可以重寫如下......

Sub ImportMultipleCSV()
    With Application
        .DisplayAlerts = False[/span
        .EnableEvents = False[/span
        .ScreenUpdating = False[/span
    結束 與
    
    Dim destWS As 作業表
    Set destWS = ThisWorkbook.Worksheets("匯入資料")

    destWS.Range("A3:AV100").ClearContents
    
    Dim fileCount As Long
    fileCount =0
    
    Dim myPathAs String
    myPath = "C:UsersDomenicDesktop" '改變相應的路徑。
    If Right(myPath, 1) <> ""  Then
        myPath = myPath & "" Then
    End If
    
    '從檔案夾中獲取第一個CSV檔案
    Dim myFile As String
    myFile = Dir(myPath & "*.csv"/span>, vbNormal)
    
    '回圈瀏覽檔案夾中的每個CSV。
    While Len(myFile) > 0
        '匯入多個csv的分號定界。
        With destWS.QueryTables.Add（Connection:= _
          "TEXT;" & myPath & myFile, Destination:=destWS.Range("A" & destWS. Rows.Count).End(xlUp).Offset(1, 0)
            .名稱 = myFile
            .FieldNames = False False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False[/span
            .RefreshStyle = xlInsertDeleteCells
            
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437[/span
            .TextFileStartRow = 2
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = True
            .TextFileCommaDelimiter = True[/span]。
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        結束 與
        fileCount = fileCount  1
        myFile = Dir '從檔案夾中獲取下一個CSV。
    補上
    
    If fileCount > 0 然后
        Dim xConnect As Object
        For Each xConnect In ActiveWorkbook.Connections
            If xConnect.Name <> "ThisWorkbookDataModel"/span> Then xConnect.Delete
        Next xConnect
    End If
    
    With Application
        .DisplayAlerts = True 應用
        .EnableEvents = True[/span
        .ScreenUpdating = True[/span
    End With .
    
    MsgBox "處理的檔案數量。" & fileCount
結束 Sub

注意，如果你的檔案實際上是由分號而不是逗號分隔的，你需要修改上面的代碼，替換成......

.TextFileCommaDelimiter = True

與

.TextFileSemicolonDelimiter = True

標籤：

上一篇：在ExcelVBA中根據輸入的月/年創建一個包括月和年的過去12個月的陣列

下一篇：VBA-查找最后一列