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

我已经用vba编写了一个脚本，它能够从我桌面上的特定文件夹导入

.xlsx

文件，并从那里复制数据，以便将其粘贴到我当前活动的工作表中。对于单个

.xlsx

文件，我的脚本运行良好

该文件夹包含100个

.xlsx

文件。其

Sheet1

中的每个文件都有固定格式的数据（行可能会有所不同）

我现在想做的是在我的活动工作表中一个接一个地从这些文件中获取所有数据（

在行中一个接一个地追加）

）

我迄今为止的努力：

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

使用VBA（而不是类似于Power Query的工具）并假设您希望复制（打开的工作簿的）第一张工作表中的数据，并粘贴到

此工作簿中的
“Sheet1”
，代码可能如下所示

在运行下面的代码之前，最好先复制整个文件夹（包含
.xlsx
文件）（不需要，但只是以防万一）

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

使用VBA（而不是类似于Power Query的工具）并假设您希望复制（打开的工作簿的）第一张工作表中的数据，并粘贴到
此工作簿中的
“Sheet1”
，代码可能如下所示

在运行下面的代码之前，最好先复制整个文件夹（包含
.xlsx
文件）（不需要，但只是以防万一）

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

打开并导入文件
代码
打开并导入文件
代码
这就是我最终达到目的的方式：

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

这就是我最终达到目的的方式：

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

可能有用此文件位置中xlsx文件的标准是什么？是否需要打开所有文件才能移动数据？100个文件是很多文件-有没有可能超过1048576行？谢谢@dwirony的评论。除非有更好的方法，否则需要打开所有文件来移动数据。这些文件的累积行数可能是10000（更多或更少）。可能有用此文件位置中xlsx文件的标准是什么？是否需要打开所有文件才能移动数据？100个文件是很多文件-有没有可能超过1048576行？谢谢@dwirony的评论。除非有更好的方法，否则需要打开所有文件来移动数据。这些文件的累积行数可能是10000（更多或更少）。
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