Question

我发现此代码可以将多个csv / text文件中的数据导入excel工作簿。但是，我希望将数据附加到单个工作表而不是每个csv / text文件都有自己的工作表。

我尝试使用Connection来获取数据，但是当文件通过电子邮件发送给其他用户时，当他/她点击＆＃时会出现错误提示（Excel无法找到文本文件以刷新此外部数据范围） 34;启用内容＆＃34;。

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

将多个text / csv文件导入单个excel工作表

3 个答案: