excel - 如何打开多个工作簿以从中复制数据

Question

我在 vba 中编写了一个脚本，它能够导入 .xlsx从我桌面上的特定文件夹中创建文件并从那里复制数据，以便将其粘贴到我当前事件的工作表中。我的脚本在单个 .xlsx 上运行良好文件。

该文件夹包含 100 个 .xlsx文件。 Sheet1 中的每个文件具有固定列的数据(行可能会有所不同)。

我现在想做的是在我的事件工作表(appended one after another in row-wise)中一一获取这些文件中的所有数据.

到目前为止我的尝试:

Sub OpenAndImportFile()
    Dim wbO As Workbook, wsI As Worksheet, cel As Range

    Set wsI = ThisWorkbook.Worksheets("Sheet1")

    Set wbO = Workbooks.Open("C:\Users\WCS\Desktop\files\coworking\list_members-coworking-annkingman-2018-12-31-14-55-07-eisaiah_e.xlsx")

    For Each cel In wbO.Sheets(1).Range("A1:A" & wbO.Sheets(1).Cells(Rows.count, 1).End(xlUp).row)
        cel(1, 1).EntireRow.Copy wsI.Range(cel(1, 1).Address)
    Next cel

    wbO.Close SaveChanges:=False
End Sub

Answer 1

使用 VBA(而不是 Power Query 之类的东西)并假设您要从第一张工作表(您打开的工作簿的)复制数据并粘贴到 "Sheet1" 中的 Thisworkbook ，代码可能如下所示。

在运行下面的代码之前复制整个文件夹(包含 .xlsx 文件)可能会很好(不必要，但以防万一)。

如果您有数百个文件要打开，您可能希望在 Application.ScreenUpdating 循环之前和之后切换 For(以防止不必要的屏幕闪烁和重绘)。

Option Explicit

Private Sub CopyPasteSheets()
    Dim folderPath As String
    folderPath = "C:\Users\WCS\Desktop\files\coworking\"

    If Len(VBA.FileSystem.Dir$(folderPath, vbDirectory)) = 0 Then
        MsgBox ("'" & folderPath & "' does not appear to be a valid directory." & vbNewLine & vbNewLine & "Code will stop running now.")
        Exit Sub
    End If

    Dim filePathsFound As Collection
    Set filePathsFound = New Collection

    Dim Filename As String
    Filename = VBA.FileSystem.Dir$(folderPath & "*.xlsx", vbNormal)

    Do Until Len(Filename) = 0
        filePathsFound.Add folderPath & Filename, Filename
        Filename = VBA.FileSystem.Dir$()
    Loop

    Dim filePath As Variant ' Used to iterate over collection
    Dim sourceBook As Workbook

    Dim destinationSheet As Worksheet
    Set destinationSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called
    'destinationSheet.Cells.Clear ' Uncomment this line if you want to clear before beginning

    Dim rowToPasteTo As Long
    rowToPasteTo = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row
    If rowToPasteTo > 1 Then rowToPasteTo = rowToPasteTo + 1

    For Each filePath In filePathsFound
        On Error Resume Next
        Set sourceBook = Application.Workbooks.Open(Filename:=filePath, ReadOnly:=True)
        On Error GoTo 0

        If Not (sourceBook Is Nothing) Then
            With sourceBook.Worksheets(1) ' Might be better if you refer to sheet by name rather than index
                Dim lastRowToCopy As Long
                lastRowToCopy = .Cells(.Rows.Count, "A").End(xlUp).Row

                With .Range("A1:A" & lastRowToCopy).EntireRow
                    If (rowToPasteTo + .Rows.Count - 1) > destinationSheet.Rows.Count Then
                        MsgBox ("Did not paste rows from '" & sourceBook.FullName & "' due to lack of rows on sheet." & vbNewLine & vbNewLine & "Code will close that particular workbook and then stop running.")
                        sourceBook.Close
                        Exit Sub
                    End If

                    .Copy destinationSheet.Cells(rowToPasteTo, "A").Resize(.Rows.Count, 1).EntireRow
                    rowToPasteTo = rowToPasteTo + .Rows.Count
                End With
            End With
            sourceBook.Close
            Set sourceBook = Nothing
        Else
            MsgBox ("Could not open file at '" & CStr(sourceBook) & "'. Will try to open remaining workbooks.")
        End If
    Next filePath
End Sub