从多个 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:UsersXXXDesktopTEST")
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:UsersXXXDesktopTEST")
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:UsersXXXDesktopTEST")
' 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