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

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之类的东西），并假设您要从（打开的工作簿的）第一张表中复制数据并粘贴到Thisworkbook "Sheet1"中，代码可能类似于以下内容。

在运行下面的代码之前，最好制作整个文件夹（包含.xlsx文件）的副本（不必要，但以防万一）。

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

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

Answer 2

打开和导入文件

编码

Sub OpenAndImportFile()

    ' Source File Folder Path
    Const cStrFolder As String = "C:\Users\WCS\Desktop\files\coworking"
    Const cStrExt As String = "*.xls*"         ' Source File Pattern
    Const cVntSrcName As Variant = 1           ' Source Worksheet Name/Index
    Const cVntSource As Variant = "A"          ' Source Column Letter/Number

    Const cVntTgtName As Variant = "Sheet1"    ' Target Worksheet Name/Index
    Const cVntTarget As Variant = "A"          ' Target Column Letter/Number

    Dim objWbSource As Workbook   ' Source Workbook
    Dim objRngU As Range          ' Source Union Range
    Dim StrFile As String         ' Source File Name
    Dim i As Long                 ' Source Row Counter
    Dim j As Long                 ' Target Row Counter

    Dim objWsTarget As Worksheet  ' Target Worksheet
    Dim cLngPasteRow As Long      ' Target Paste Row

    Set objWsTarget = ThisWorkbook.Worksheets(cVntTgtName)
    objWsTarget.Cells.Clear

    cLngPasteRow = 1

    StrFile = Dir(cStrFolder & "\" & cStrExt)

    On Error GoTo ProcedureExit

    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .DisplayAlerts = False
    End With

    Do While Len(StrFile) > 0

        Set objWbSource = Workbooks.Open(cStrFolder & "\" & StrFile)

        With objWbSource.Worksheets(1)

'            Debug.Print objWbSource.Name & "  " & .Name & "   " & cLngPasteRow

            If .Cells(.Rows.Count, cVntSource).End(xlUp).Row = 1 _
                And .Cells(1, 1) = "" Then
              Else
                For i = 1 To .Cells(.Rows.Count, cVntSource).End(xlUp).Row
                    If Not objRngU Is Nothing Then
                        Set objRngU = Union(objRngU, .Cells(i, cVntSource))
                      Else
                        Set objRngU = .Cells(i, cVntSource)
                    End If
                    j = j + 1
                Next
            End If
        End With

        If Not objRngU Is Nothing Then
            objRngU.EntireRow.Copy objWsTarget.Cells(cLngPasteRow, cVntTarget)
            Set objRngU = Nothing
            cLngPasteRow = j + 1 ' Next row to copy data to.
        End If

        objWbSource.Close False

        StrFile = Dir

    Loop

ProcedureExit:

    Set objRngU = Nothing
    Set objWbSource = Nothing
    Set objWsTarget = Nothing

    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    End With


End Sub

Answer 3

这是我最终实现目标的方式：

Sub OpenAndImportFile()
    Dim wbO As Workbook, wsI As Worksheet, cel As Range
    Dim daddr$, Filename$, foundfiles As New Collection
    Dim xlfile As Variant

    Application.ScreenUpdating = False

    daddr = Environ("USERPROFILE") & "\Desktop\files\coworking\"
    Filename = Dir(daddr & "*.xlsx")
    Set wsI = ThisWorkbook.Worksheets("Sheet1")

    Do While Len(Filename) > 0
        foundfiles.Add Filename
        Filename = Dir
    Loop

    For Each xlfile In foundfiles
        Set wbO = Workbooks.Open(daddr & xlfile)

        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("A" & Rows.count).End(xlUp).Offset(1, 0)
        Next cel
        wbO.Close SaveChanges:=False
    Next xlfile

    Application.ScreenUpdating = True
End Sub