Импорт нескольких текстовых/CSV-файлов в один рабочий лист excel

Question

Я нашел этот код, чтобы получить данные из нескольких CSV/текстовых файлов в книгу Excel. Тем не менее, я хотел бы, чтобы данные были добавлены к одному листу, а не к каждому файлу csv/text, имеющему собственный рабочий лист.

Я попытался использовать Connection для получения данных, но когда файл отправляется другому пользователю, появляется сообщение об ошибке (Excel не может найти текстовый файл для обновления этого диапазона внешних данных), когда он нажимает кнопку " Включить содержимое ".

Sub CombineTextFiles() 
    Dim FilesToOpen 
    Dim x As Integer 
    Dim wkbAll As Workbook 
    Dim wkbTemp As Workbook 
    Dim sDelimiter As String 

    On Error GoTo ErrHandler 
    Application.ScreenUpdating = False 

    sDelimiter = "|" 

    FilesToOpen = Application.GetOpenFilename _ 
     (FileFilter:="CSV Files (*.csv), *.csv", _ 
     MultiSelect:=True, Title:="Text Files to Open") 

    If TypeName(FilesToOpen) = "Boolean" Then 
     MsgBox "No Files were selected" 
     GoTo ExitHandler 
    End If 

    x = 1 
    Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x)) 
    wkbTemp.Sheets(1).Copy 
    Set wkbAll = ActiveWorkbook 
    wkbTemp.Close (False) 
    wkbAll.Worksheets(x).Columns("A:A").TextToColumns _ 
     Destination:=Range("A1"), DataType:=xlDelimited, _ 
     TextQualifier:=xlDoubleQuote, _ 
     ConsecutiveDelimiter:=False, _ 
     Tab:=False, Semicolon:=False, _ 
     Comma:=False, Space:=False, _ 
     Other:=True, OtherChar:="|" 
     x = x + 1 

    While x <= UBound(FilesToOpen) 
     Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x)) 
     With wkbAll 
      wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count) 
      .Worksheets(x).Columns("A:A").TextToColumns _ 
       Destination:=Range("A1"), DataType:=xlDelimited, _ 
       TextQualifier:=xlDoubleQuote, _ 
       ConsecutiveDelimiter:=False, _ 
       Tab:=False, Semicolon:=False, _ 
       Comma:=False, Space:=False, _ 
       Other:=True, OtherChar:=sDelimiter 
     End With 
     x = x + 1 
    Wend 

ExitHandler: 
    Application.ScreenUpdating = True 
    Set wkbAll = Nothing 
    Set wkbTemp = Nothing 
    Exit Sub 

ErrHandler: 
    MsgBox Err.Description 
    Resume ExitHandler 
End Sub 

Answer 1

Я использовал этот, чтобы получить файлы. Недостатком является то, что он получает все данные в эту книгу.

Sub getallbooks() 

Dim firstRowHeaders As Boolean 
Dim fso As Object 
Dim dir As Object 
Dim filename As Variant 
Dim wb As Workbook 
Dim s As Sheet1 
Dim thisSheet As Sheet1 
Dim lastUsedRow As Range 
Dim file As String 
Dim fpath As String 

On Error GoTo ErrMsg 

Application.ScreenUpdating = False 
firstRowHeaders = True 'Change from True to False if there are no headers in the first row 

Set fso = CreateObject("Scripting.FileSystemObject") 

'PLEASE NOTE: Change <<Full path to your Excel files folder>> to the path to the folder containing your Excel files to merge 
fpath = Application.InputBox("Enter the file folder") 
Set dir = fso.Getfolder(fpath) 

Set thisSheet = ThisWorkbook.ActiveSheet 

For Each filename In dir.Files 
'Open the spreadsheet in ReadOnly mode 
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True) 

'Copy the used range (i.e. cells with data) from the opened spreadsheet 
If firstRowHeaders And i > 0 Then 'Only include headers from the first spreadsheet 
    Dim mr As Integer 
    mr = wb.ActiveSheet.UsedRange.Rows.Count 
    wb.ActiveSheet.UsedRange.Offset(1, 0).Resize(mr - 1).Copy 
Else 
    wb.ActiveSheet.UsedRange.Copy 
End If 

'Paste after the last used cell in the master spreadsheet 
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows 
    Set lastUsedRow = thisSheet.Range("A65536").End(xlUp) 
Else 
    Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp) 
End If 

'Only offset by 1 if there are current rows with data in them 
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then 
    Set lastUsedRow = lastUsedRow.Offset(1, 0) 
End If 
lastUsedRow.PasteSpecial 
Application.CutCopyMode = False 
Next filename 

ThisWorkbook.Save 
Set wb = Nothing 

#If Mac Then 
'Do nothing. Closing workbooks fails on Mac for some reason 
#Else 
'Close the workbooks except this one 
For Each filename In dir.Files 
    file = Right(filename, Len(filename) - InStrRev(filename, Application.PathSeparator, , 1)) 
    Workbooks(file).Close SaveChanges:=False 
Next filename 
#End If 

Application.ScreenUpdating = True 
ErrMsg: 
If Err.Number <> 0 Then 
MsgBox "There was an error. Please try again. [" & Err.Description & "]" 
End If 

End Sub 

Вот еще один способ, который создает новую книгу для хранения данных:

Sub MergeAllWorkbooks() 
Dim MyPath As String, FilesInPath As String 
Dim MyFiles() As String 
Dim SourceRcount As Long, FNum As Long 
Dim mybook As Workbook, BaseWks As Worksheet 
Dim sourceRange As Range, destrange As Range 
Dim rnum As Long, CalcMode As Long 
Dim LastRow As Long, LastCol As Long 

' Change this to the path\folder location of your files. 
MyPath = InputBox("Enter the address here") 

' Add a slash at the end of the path if needed. 
If Right(MyPath, 1) <> "\" Then 
    MyPath = MyPath & "\" 
End If 

' If there are no Excel files in the folder, exit. 
FilesInPath = Dir(MyPath & "*.csv*") 'You can change the file type to suit your need here 
If FilesInPath = "" Then 
    MsgBox "No files found" 
    Exit Sub 
End If 

' Fill the myFiles array with the list of Excel files 
' in the search folder. 
FNum = 0 
Do While FilesInPath <> "" 
    FNum = FNum + 1 
    ReDim Preserve MyFiles(1 To FNum) 
    MyFiles(FNum) = FilesInPath 
    FilesInPath = Dir() 
Loop 

' Set various application properties. 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Add a new workbook with one sheet. 
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 
rnum = 1 

' Loop through all files in the myFiles array. 
If FNum > 0 Then 
    For FNum = LBound(MyFiles) To UBound(MyFiles) 
     Set mybook = Nothing 
     On Error Resume Next 
     Set mybook = Workbooks.Open(MyPath & MyFiles(FNum)) 
     On Error GoTo 0 

     If Not mybook Is Nothing Then 
      On Error Resume Next 

      ' Change this range to fit your own needs. 
      With mybook.Worksheets(1) 
       LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 'choose which column has data all the way down the last row 
       LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column 

       Set sourceRange = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)) 

      End With 

      If Err.Number > 0 Then 
       Err.Clear 
       Set sourceRange = Nothing 
      Else 
       ' If source range uses all columns then 
       ' skip this file. 
       If sourceRange.Columns.Count >= BaseWks.Columns.Count Then 
        Set sourceRange = Nothing 
       End If 
      End If 
      On Error GoTo 0 

      If Not sourceRange Is Nothing Then 

       SourceRcount = sourceRange.Rows.Count 

       If rnum + SourceRcount >= BaseWks.Rows.Count Then 
        MsgBox "There are not enough rows in the target worksheet." 
        BaseWks.Columns.AutoFit 
        mybook.Close savechanges:=False 
        GoTo ExitTheSub 
       Else 

        ' Copy the file name in column A, if you want; Here I choose not. 
        ' With sourceRange 
         ' BaseWks.Cells(rnum, "A"). _ 
           ' Resize(.Rows.Count).Value = MyFiles(FNum) 
        ' End With 

        ' Set the destination range. 
        Set destrange = BaseWks.Range("A" & rnum) 

        ' Copy the values from the source range 
        ' to the destination range. 
        With sourceRange 
         Set destrange = destrange. _ 
             Resize(.Rows.Count, .Columns.Count) 
        End With 
        destrange.Value = sourceRange.Value 

        rnum = rnum + SourceRcount 
       End If 
      End If 
      mybook.Close savechanges:=False 
     End If 

    Next FNum 
    BaseWks.Columns.AutoFit 
End If 

ExitTheSub: 
' Restore the application properties. 
With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = CalcMode 
End With 
End Sub 

Оба из них получают заголовок из каждого файла. Таким образом, вы можете удалить их только с одной верхней.

Answer 2

Рассмотрите возможность использования QueryTables, которые подключаются к текстовым файлам и завернуть в цикле ваших нескольких выбранных файлов CSV из массива, filesToOpen:

Sub ImportCSVFiles() 

    Dim filesToOpen As Variant, file As Variant, LastRow As Long, fso As Object 

    filesToOpen = Application.GetOpenFilename _ 
     (FileFilter:="CSV Files (*.csv), *.csv", _ 
     MultiSelect:=True, Title:="Text Files to Open") 

    For Each file In filesToOpen 

     LastRow = Cells(Rows.Count, 1).End(xlUp).Row 
     Set fso = CreateObject("Scripting.FileSystemObject") 
     fileName = fso.GetFilename(i) 

     If file = "False" Then Exit Sub 

     'IMPORT DATA FROM CSV FILES 
     With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & file, _ 
      Destination:=Cells(LastRow + 2, 1)) 
       .TextFileStartRow = 30 
       .TextFileParseType = xlDelimited 
       .TextFileConsecutiveDelimiter = False 
       .TextFileTabDelimiter = False 
       .TextFileSemicolonDelimiter = False 
       .TextFileCommaDelimiter = True 
       .TextFileSpaceDelimiter = False 

       .Refresh BackgroundQuery:=False 
     End With 

    Next file 

    ' REMOVING SOURCE CONNECTIONS 
    For Each qt In ActiveSheet.QueryTables 
     qt.Delete 
    Next qt 

End Sub 

Answer 3

Спасибо за ответы. Вместо использования кода, который я поделил выше, я повторно использовал соединение, которое было моим исходным кодом. Чтобы отменить запрос на ошибку соединения (Excel не может найти текстовый файл для обновления этого диапазона внешних данных), когда он нажимает «Включить контент», я добавил код, который удаляет все соединения после импорта данных в файл excel. Надеюсь, это полезно для тех, кто столкнулся с той же проблемой, что и я.)

Sub ImportMultipleCSV() 

Dim myfiles 
Dim i As Integer 

myfiles = Application.GetOpenFilename(filefilter:="CSV Files (*.csv), *.csv", MultiSelect:=True) 

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 
      .RowNumbers = False 
      .FillAdjacentFormulas = False 
      .PreserveFormatting = True 
      .RefreshOnFileOpen = False 
      .RefreshStyle = xlInsertDeleteCells 
      .SavePassword = False 
      .SaveData = True 
      .AdjustColumnWidth = True 
      .RefreshPeriod = 0 
      .TextFilePromptOnRefresh = False 
      .TextFilePlatform = 437 
      .TextFileStartRow = 2 
      .TextFileParseType = xlDelimited 
      .TextFileTextQualifier = xlTextQualifierDoubleQuote 
      .TextFileConsecutiveDelimiter = True 
      .TextFileTabDelimiter = False 
      .TextFileSemicolonDelimiter = False 
      .TextFileCommaDelimiter = False 
      .TextFileSpaceDelimiter = False 
      .TextFileOtherDelimiter = "|" 
      .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1) 
      .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 

End Sub