从多个工作簿的Excelmacros复制粘贴到数据表结束

我试图进入一个文件夹，打开每个文件，从某个表“logging”中复制数据，将该数据粘贴到macros在“数据”选项卡上的文件中。 数据应该添加，所以每个文件的数据应该显示出来。 我无法获取数据粘贴到最后，而不是每次特定的单元格。 我曾尝试使用一个variables是最后一行并抵消它，但粘贴只是不工作，并一直抛出错误。 我绝望的帮助！ 我一直在search博客几个小时。 你可以看到我下面的代码：

Sub copyMultFilesv2() Dim rS As Range, rT As Range, Cel As Range Dim wBs As Workbook 'source workbook Dim wS As Worksheet 'source sheet Dim wT As Worksheet 'target sheet Dim x As Long 'counter Dim c As String Dim arrFiles() As String 'list of source files Dim myFile As String 'source file Dim RowLast As Long Dim csTRng As Range Dim csSRng As Range Dim lastrow As Long Dim datatocopy As Range Dim opencell As Range ' change these to suit requirements Const csMyPath As String = "C:\Users\Whatley Macie\Desktop\TestTWC\" 'source folder Const csMyFile As String = "*.xl*" 'source search pattern 'Set csSRng = Worksheets("Record").Range("A2:Z" & Range("A1").End(xlDown).Row) 'source range ' Set csTRng = Worksheets("Data").Range("A1").End(xlDown).Offset(1, 0) 'target range make is the end of target Application.ScreenUpdating = False ' target sheet Set wT = ThisWorkbook.Worksheets("Data") 'change to suit ' aquire list of files ReDim arrFiles(1 To 1) myFile = Dir$(csMyPath & csMyFile, vbNormal) Do While Len(myFile) > 0 arrFiles(UBound(arrFiles)) = myFile ReDim Preserve arrFiles(1 To UBound(arrFiles) + 1) myFile = Dir$ Loop ReDim Preserve arrFiles(1 To UBound(arrFiles) - 1) Set rT = wT.Range("A" & Rows.count).End(xlUp).Offset(1) 'c = wT.UsedRange.Rows.count 'csTRng ' loop thru list of files For x = 1 To UBound(arrFiles) Set wBs = Workbooks.Open(csMyPath & arrFiles(x), False, True) 'open wbook Set wS = wBs.Worksheets("Record") 'change sheet to suit 'datatocopy = wS.Range("A2:Z" & Range("A1").End(xlDown).row).Select 'datatocopy.PasteSpecial 'xlPasteAll Application.CutCopyMode = False 'opencell = ("A" & c) c = ActiveSheet.UsedRange.Rows.count 'Copy the data 'wS.Range("A2:Z" & Range("A1").End(xlDown).row).Value = wT.Range("A2").Offset(c).Value wS.Range("A2:Z" & Range("A1").End(xlDown).row).Copy 'wT.Range("A2").Value = wS.Range("A2:Z100").Value 'Sheets("").Range("A1:B10").Copy 'Activate the destination worksheet wT.Activate 'Select the target range 'ActiveCell(c + 1, 1).PasteSpecial xlPasteValues Dim target As Range Set target = Cells((c + 1), 1) 'Range("A2").Offset(c, 0).Select target.Select 'Range("A2").Offset(RowOffset:=c).Select 'Paste in the target destination 'ActiveCell.Offset (c) target.Paste Application.CutCopyMode = False 'rT.Offset(1,0) wBs.Close False 'Set rT = rT.Offset(1) 'next row DoEvents Next x 'next book Erase arrFiles Application.ScreenUpdating = True End Sub 

Answer 1

我有两个解决scheme:(也可以打开屏幕更新，而你正在这个工作）

1. 首先select要粘贴的工作表，然后select要粘贴到的单元格。
2. 使用数组（您的代码将运行得更快），这是未经testing，所以检查我的拼写。

。

 Dim arraySource as variant 'somewhere in the start 'Note: c should be saved as a long not a string arraySource = wS.Range("A2:Z" & Range("A1").End(xlDown).row) ' populate your array instead of wS.Range("A2:Z" & Range("A1").End(xlDown).row).Copy wt.range("A" & c : "A" & (c + ubound(arraySource)) = arraySource 

再次未经testing，但尝试一下。