У меня была та же проблема, и я хотел добавить несколько (16, если быть точным) CSV-файлов в один листинг. Массив, который я использовал, является статическим, и есть лучшие способы его кодирования, но мне нужно было собрать определенные файлы из нескольких CSV-файлов, которые находятся в папке.
Я нашел ваш код интересным, и обновил код, который я собрал из других источников, чтобы заставить набор кода работать.
Спасибо, что поделились своим кодом, как вы увидите, я использовал элемент вашего кода, чтобы найти следующую пустую строку для добавления.
Ниже приведен пример кода, вам необходимо добавить имена файлов и путь к каталогу файлов, а также обновить массив xFiles, чтобы он соответствовал количеству файлов, которые вы хотите импортировать и добавить:
Sub LoadDelimitedFiles() Dim xStrPath As String Dim xFile As String Dim xCount As Long Dim xFiles(15) As String Dim destCell As Range On Error GoTo ErrHandler 'added an update to the code to select the individual file names needed from server within a folder 'PathName of Folder Location xStrPath = "<Insert Folder Location>" 'Name the Array with the CSV files name for file Content xFiles(0) = "<Filename1>" xFiles(1) = "<Filename2>" xFiles(2) = "<Filename3>" xFiles(3) = "<Filename4>" xFiles(4) = "<Filename5>" xFiles(5) = "<Filename6>" xFiles(6) = "<Filename7>" xFiles(7) = "<Filename8>" xFiles(8) = "<Filename9>" xFiles(9) = "<Filename10>" xFiles(10) = "<Filename11>" xFiles(11) = "<Filename12>" xFiles(12) = "<Filename13>" xFiles(13) = "<Filename14>" xFiles(14) = "<Filename15>" xFiles(15) = "<Filename16>" xCount = 0 If xStrPath = "" Then Exit Sub Application.ScreenUpdating = False 'Clear Existing Sheet Data Columns("A:I").Select Selection.Delete Shift:=xlToLeft Range("A1").Select 'Set the 1st Filename xFile = Dir(xStrPath & xFiles(xCount) & ".csv") 'destCell contains the location of the next cell to append the next csv file data to Set destCell = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1) Do While xCount <> 16 xFile = Dir(xStrPath & xFiles(xCount) & ".csv") With ActiveSheet.QueryTables.Add(Connection:="TEXT;" _ & xStrPath & xFile, Destination:=destCell) .Name = "a" & xCount .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 .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = False .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = True .TextFileSpaceDelimiter = False .TextFileOtherDelimiter = False .TextFileColumnDataTypes = Array(1, 1, 1) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False Set destCell = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1) xCount = xCount + 1 End With Loop 'Remove the Blank Top row Rows("1:1").Select Selection.Delete Shift:=xlUp Range("A1").Select 'Update the screen to show the contents appended csv file data Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox "no files found",, "Error Message" End Sub