我得到了这个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
您无需逐个单元复制。您可以一次复制整个范围,这要快得多。
另外,请确保指定要复制到的工作簿和工作表。切勿使用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)
。
请注意,复制完整范围总是比逐个单元复制相同的数据快,因为只需要执行一次复制操作。
本文收集自互联网,转载请注明来源。
如有侵权,请联系[email protected] 删除。
我来说两句