从多个excel文件复制单元格并将它们粘贴到主文件中

Question

我得到了这个 VBA 代码，它应该从关闭的 excel 文件（位于一个文件夹中）中读出单元格并将内容复制到主文件中。 它似乎按预期读出文件，但是粘贴复制的竞争似乎不起作用。

有任何想法吗？

Sub ReadAndMerceData()

Dim objFs As Object
Dim objFolder As Object
Dim file As Object

Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFs.GetFolder("C:\Users\XXX\Desktop\TEST")

Dim iStartRow As Integer
iStartRow = 0

For Each file In objFolder.Files

    Dim src As Workbook
    Set src = Workbooks.Open(file.Path)

    Dim iTotalRows As Integer
    iTotalRows = 50

    Dim iTotalCols As Integer
    iTotalCols = 17
    Dim iRows, iCols As Integer

    For iRows = 1 To iTotalRows
        For iCols = 1 To iTotalCols
            Cells(iRows + iStartRow, iCols) = src.Worksheets("Tabelle1").Cells(iRows, iCols)
        Next iCols
    Next iRows

    iStartRow = iRows + 1
    iRows = 0

    src.Close False
    Set src = Nothing
Next

End Sub

Answer 1

您不需要逐个单元格复制。 您可以一次复制整个范围，这要快得多。

还要确保指定要复制到的工作簿和工作表。 切勿在未指定工作表的情况下使用Range或Cells （否则 Excel 会猜测并且可能是错误的）。

Option Explicit

Public Sub ReadAndMerceData()
    Dim objFs As Object        
    Set objFs = CreateObject("Scripting.FileSystemObject")

    Dim objFolder As Object
    Set objFolder = objFs.GetFolder("C:\Users\XXX\Desktop\TEST")

    Dim dest As Worksheet 'define your destination sheet!
    Set dest = ThisWorkbook.Worksheets("DestinationSheet")

    'make them variabes if they are dynamic otherwise use constants if hardcoded.
    Const TotalRows As Long = 50
    Const TotalCols As Long = 17 

    Dim iStartRow As Long

    Dim file As Object
    For Each file In objFolder.Files
        Dim src As Workbook
        Set src = Workbooks.Open(file.Path)

        'copy all cells at once
        dest.Cells(iStartRow + 1, 1).Resize(TotalRows, TotalCols).Value = src.Worksheets("Tabelle1").Cells(1, 1).Resize(TotalRows, TotalCols).Value

        iStartRow = iStartRow + TotalRows + 1

        src.Close SaveChanges:=False
    Next file
End Sub

解释

这个dest.Cells(iStartRow + 1, 1)是我们想要复制到的第一个单元格，所以使用.Resize(TotalRows, TotalCols)我们将该单元格扩展到一个范围并将其.Value设置为等于开始于的源工作表范围第一个单元格src.Worksheets("Tabelle1").Cells(1, 1)并且具有相同数量的行和列.Resize(TotalRows, TotalCols) 。

请注意，复制完整范围始终比逐个单元格复制相同数据要快，因为只需执行 1 个复制操作。

Answer 2

遵循@BigBen 和@Pᴇʜ 的建议，并稍微排序您的代码以提高效率，请尝试以下修改后的代码：

Option Explicit

Sub ReadAndMerceData()

' Objects and parameters declaration section
Dim objFs As Object
Dim objFolder As Object
Dim file As Object
Dim src As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim iStartRow As Long, iTotalRows As Long, iTotalCols As Long, iRows As Long, iCols As Long

Set objFs = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFs.GetFolder("C:\Users\XXX\Desktop\TEST")

' remove screen flickering (speed your code's run-time)
Application.ScreenUpdating = False

' set the result worknook and worksheet objects (modify to suit your needs)
Set wb = ThisWorkbook
Set ws = wb.Worksheets("sheet1") ' <-- modify "Sheet1" to your sheet's name

' set your parameters once, don't need to set them every time inside the loop
iStartRow = 0
iTotalRows = 50
iTotalCols = 17
For Each file In objFolder.Files
    Set src = Workbooks.Open(file.Path)

    For iRows = 1 To iTotalRows
        For iCols = 1 To iTotalCols
            ws.Cells(iRows + iStartRow, iCols) = src.Worksheets("Tabelle1").Cells(iRows, iCols)
        Next iCols
    Next iRows

    iStartRow = iRows + 1
    iRows = 0

    src.Close False
    Set src = Nothing
Next

Application.ScreenUpdating = True

End Sub